無限ループに陥ってしまいました。(Excel)

質問

シート上に文字列がランダムにばら撒かれています。
(ばら撒かれている範囲もケースバイケースを想定しています)
最終的に、文字列をA１から順番に並べたいと思いました。
手順としてＡ列の文字列が入力されているセル行を調べてその回数ループさせる。もし、セルの値が""ならばセルを削除し上に詰める。そのときＡ列の最終行数を-1する。最終行数までくるとその列は終わり。
次の列に移動し繰り返して完了。
と、もくろんだのですが、Ａ列のみで無限ループに陥ってしまいました。どなたか？詳しい方いらっしゃいましたら教えてください。

Sub test()
Set sh1 = Worksheets("sheet1")
For j = 1 To 50
LastRow1 = sh1.Cells(65536, j).End(xlUp).Row
For i = 1 To LastRow1
If sh1.Cells(i, j).Value = "" Then
sh1.Cells(i, j).Delete (xlShiftUp)
i = i - 1
LastRow1 = LastRow1 - 1
End If
Next
Next
End Sub

回答No.4

Wendy02 · ベストアンサー

こんばんは。

あまりご質問をちゃんと読んでいないので、上手くいかないかもしれませんが、こんな風に作ってみました。たぶん、空のセルを削除して、最後の要件は、空いた列を左に寄せていくのですよね。

Sub DeleteBlankCells()
　Dim i As Integer
　With ActiveSheet
　　On Error Resume Next
　　For i = .Range("A1").SpecialCells(xlCellTypeLastCell).Column To 1 Step -1
　　　.Columns(i).SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
　　　If WorksheetFunction.CountA(.Columns(i)) = 0 Then
　　　　.Columns(i).Delete
　　　End If
　　Next i
　　On Error GoTo 0
　End With
End Sub

お礼

丁寧は回答有難う御座います。
私が書いたマクロの10倍ぐらいの速度で、処理が完了してしまいました。画面の更新を止める必要がないほどに！！
マクロには、独特の考え方と、深い知識が必要なことを痛感しました。
今後とも宜しくお願いいたします。

回答No.3

noname#91724

For Next文の中に

If i = LastRow1 Then
Exit For
End If

と入れてみたらどうでしょ？

お礼

ご回答ありがとうございます。
結局、教えて頂いた内容を踏まえて次のようになりました。
何か？指摘頂ければと思います。
皆さんも宜しくお願いいたします。
Sub test()
Application.ScreenUpdating = False
Set sh1 = Worksheets("sheet1")
Dim Column_address As String
Column_address = sh1.UsedRange.Address
right_botmm_address = Right(Column_address, Len(Column_address) - InStrRev(Column_address, ":"))
Last_Column = sh1.Range(right_botmm_address).Column
For j = 1 To Last_Column
LastRow1 = sh1.Cells(65536, j).End(xlUp).Row
For i = LastRow1 To 1 Step -1
If sh1.Cells(i, j).Value = "" Then
sh1.Cells(i, j).Delete (xlShiftUp)
End If
Next
Next
StartRowA = 1
For j = 2 To Last_Column
LastRow1 = sh1.Cells(65536, j).End(xlUp).Row
sh1.Range(Cells(1, j), Cells(LastRow1, j)).Cut
sh1.Range(Cells(StartRowA, 1), Cells(StartRowA, 1)).Select
sh1.Paste
StartRowA = StartRowA + LastRow1
Next
Application.ScreenUpdating = True
End Sub

回答No.2

merlionXX

No1です。
すみません、勘違いしてました。行を削除ではなくセルの削除でしたね。
大丈夫でした。
お騒がせしました。

回答No.1

merlionXX

無限ループは以下のように下の行から削除していけば大丈夫です。
ただ、このままでは、A列以外は、A列の同じ行が空白だと、最初に削除されてしまいますよ。考え直した方がいいと思います。

Sub test()
Set sh1 = Worksheets("sheet1")
For j = 1 To 50
LastRow1 = sh1.Cells(65536, j).End(xlUp).Row
For i = LastRow1 To 1 Step -1
If sh1.Cells(i, j).Value = "" Then
sh1.Cells(i, j).Delete (xlShiftUp)
End If
Next
Next
End Sub

お礼

ありがとうございます。
下から、削除なんですね。助かりました。
次の課題は、セルの範囲幅の検出と、Ａ列への集合です。
また悩みそうなので、今から心配です。
また、宜しくお願いいたします。