空であるか、空白のみを含む列の最初のセルを見つける必要があります。
これは、シート（「Yahoo」）の列Aを通過します。それはあなたのために働くはずです：
Sub FindBlankOrEmptyCells()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim ws As Worksheet
Set ws = wbk.Sheets(1)
Dim cell As Range
Dim BlankCounter As Integer
Dim i As Integer
Dim OldCellValue As Variant ' just for the heck of it
For Each cell In Sheets("Yahoo").Range("A:A")
OldCellValue = cell.Value
cell.NumberFormat = "@"
cell.Value = "'" & cell.Value
BlankCounter = 0
If cell.Value = "" Then
MsgBox "Found an empty cell in Column A, Row: " & " " & cell.Row
Exit Sub
End If
For i = 1 To Len(cell)
If cell.Characters(i, 1).Text = " " Then
BlankCounter = BlankCounter + 1
End If
If BlankCounter = Len(cell) Then
MsgBox "Found a cell full of blanks in Column A, Row: " & " " & cell.Row
cell.Clear
cell.Value = OldCellValue
cell.Value = cell.Value
Exit Sub
' If you want to delete the contents of the cell or continue looping you can delete this Exit Sub and put in:
' cell.ClearContents
' then it will loop through all the cells and delete blanks and message you each time
End If
Next i
cell.Clear
cell.Value = OldCellValue
cell.Value = cell.Value
Next cell
End Sub
これにより、空であるか、空白（スペース）のみを含む最初のセルが検索されます。その基準を満たすセルが見つかると停止します。ループを続行したい場合は、コメントアウトしたコードを有効にすることができます。それがどのように機能するか教えてください。
編集：
.find関数を使用して可能な効率を実現したい場合、最終的にはセル内のすべての文字をループして、すべてのスペースが含まれているかどうかを判断する必要があります。これを試してみてください（空白のメッセージがポップアップし続けないように、行30で停止しましたが、メッセージを削除して、行999999までループまで拡張できます）：
Sub FindBlankOrEmptyCellsWithFindFunction()
Dim FindString As String
Dim Rng As Range
Set Rng = Sheets("Yahoo").Range("A1")
Dim Done As Boolean
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim ws As Worksheet
Set ws = wbk.Sheets(1)
Dim cell As Range
Dim BlankCounter As Integer
Dim i As Integer
Dim ii As Integer
Dim LoopStopperRange As Range
Dim OldCellValue As Variant
ii = 0
Do
ii = ii + 1
FindString = " "
With Sheets("Yahoo").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(Rng.Row, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then ' If Rng Is Something Then
If ii = 1 Then
Set LoopStopperRange = Rng
End If
If LoopStopperRange = Rng And ii > 1 Then
Exit Do
End If
For Each cell In Rng
OldCellValue = cell.Value
cell.NumberFormat = "@"
cell.Value = "'" & cell.Value
BlankCounter = 0
If cell.Value = "" Then
MsgBox "Found an empty cell in Column A, Row: " & " " & cell.Row
'Exit Sub
End If
For i = 1 To Len(cell)
If cell.Characters(i, 1).Text = " " Then
BlankCounter = BlankCounter + 1
End If
If BlankCounter = Len(cell) Then
MsgBox "Found a cell full of blanks in Column A, Row: " & " " & cell.Row
cell.Clear
cell.Value = OldCellValue
cell.Value = cell.Value
'Exit Sub
' If you want to delete the contents of the cell or continue looping you can delete this Exit Sub and put in:
' cell.ClearContents
' then it will loop through all the cells and delete blanks
End If
Next i
cell.Clear
cell.Value = OldCellValue
cell.Value = cell.Value
Next cell
Else
End If
End With
Loop Until Rng Is Nothing
Set Rng = Sheets("Yahoo").Range("A1")
Do
ii = ii + 1
FindString = ""
With Sheets("Yahoo").Range("A:A")
Set Rng = .Find(What:=FindString, _
After:=.Cells(Rng.Row, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then ' If Rng Is Something Then
For Each cell In Rng
OldCellValue = cell.Value
cell.NumberFormat = "@"
cell.Value = "'" & cell.Value
BlankCounter = 0
If cell.Value = "" Then
MsgBox "This loop will go until Row 30 so you don't have to pause/break out. Found an empty cell in Column A, Row: " & " " & cell.Row
'Exit Sub
End If
Next cell
Else
End If
End With
Loop Until Rng.Row = 30
'Loop Until Rng.Row = 99999
End Sub
幸運を。