VBAで空白行を削除する

質問

VBAでリストの空白行を削除するための適当なコードを探しているのですがどんぴしゃのものが中々見つかりません。ご教授下さい。

ブックBのシートBのリストにはA2～AN●まで値が入っています。
別のブックAからVBAで値を取り出し貼り付けています。

いくつかの方法を試しました。

(1)ブックを開いたときに空白行を削除
Sub Auto_Open() '空白行を削除

Dim lRow As Long
Dim i As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If Cells(i, 1).Value = "" Then
Range(i & ":" & i).Delete
End If
Next i
Application.ScreenUpdating = True

End Sub

5分以上砂時計のままで結局終わりません。
強制終了させ再度ブックを開くと空白行は削除されているのですが、こんな動作では使うことができません。

(2)ブックAの値を貼り付けた後、空白行を削除し上書き保存する
Sub エクスポート()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range(Cells(5, 7), Cells(79, 46)).Select
Selection.Copy 'コピー

Workbooks.Open Filename:="\\パス\ブックB.xlsm" '貼り付け先ファイルオープン

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '貼り付け

Dim lRow As Long
Dim i As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If Cells(i, 1).Value = "" Then
Range(i & ":" & i).Delete
End If
Next i
Application.ScreenUpdating = True　　'空白行を削除

ActiveWorkbook.Save '上書き保存

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

(3)空白行を削除の部分は以下のコードも試しました
Worksheets("SheetB").Range("A1").Select
Set currentCell = Worksheets("sheetB").Range("A1")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If Not IsEmpty(currentCell) Then 'カレントセルが空白でなく、
If IsEmpty(nextCell) Then '次のセルが空白のとき
nextCell.EntireRow.Delete
End If
End If
Set currentCell = currentCell.Offset(1, 0)
Loop '空白行削除

宜しくお願い致します。

回答No.4

satoron666

空白行の範囲選択をする前に、
With ActiveSheet'←できれば、Workbooks("Book1").Worksheets("Sheet1")とかのほうが…
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If .Range("A" & i) = "" Then
.Range("A" & i) = ""
End If
Next i
End With

これで、見た目空白なら、空白にしています。
元のプログラムを拝借しました（笑

これを、空白行選択する前にやれば
上手くいくかと思います＾＾

回答No.3

satoron666

追記です。

http://veaba.keemoosoft.com/2012/12/376/

すみません。空白行が無かった場合にエラーが出ます。
例）
On Error Resume Next
Range("A1:A10").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
On Error GoTo 0

このようにしたら、エラーは出ないと思います。

補足

たびたびご回答ありがとうございます。

ご指摘の点を直したのですが、うまくいかず

試しに空白セルを一度選択して数式と値のクリアをしてからマクロを実行すると削除してくれました。
コピー元では対象セルに
=IF(Z6="","",Z6)
のようなIF関数を入れているのですが
関数の結果が""で空白の場合にコピー先で値と認識されているのではと思いました。

どのように直せばいいのでしょうか？

たびたびの補足で申し訳ありませんが宜しくお願い致します。

回答No.2

satoron666

ブックA,ブックB等しっかり選択されていないのかな？と思います。

例）
With Workbook("ブックA.xls").Worksheets("Sheet1")
.select 'ブックAのSheet1をselectします。
　　　　.Range("A1")=”テスト”　'ブックAのSheet1のA1にテストと入力します。
End with

ブック間で色々やる場合、
単に「Range」と記入してしまうと
ブックAなのか、ブックBなのか。判断できなくなり
違うブックで動作してしまっていたりすることが良くあります。
しっかり、ブックAですよ～、Bですよ～としてあげることが一番かもしれません。
（もしかしたら私が言っていることは違うかもしれませんが…）

Withでやるのが面倒だという場合は、
Workbook("ブックB.xls").Activeと入力したり
Workbook("ブックB.xls").selectと入力したりすれば解決するかと思います。

回答No.1

satoron666

例）
Range("A1:A10").SpecialCells(xlCellTypeBlanks).Select

こうすると、空白セルを選択することができます。

そして、
Selection.EntireRow.Delete

で、選択したセルの行を削除…というのが早いかもしれません。

補足

ご回答ありがとうございます。

On Error Resume Next

Range("A2:A60000").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

On Error GoTo 0 'A列から空白行を探し出しその列全体を削除ぶｋｋ

上記のコードをブックBで実行したところうまくいきました。

ところがブックAに以下のように記述し実行したところ削除されませんでした。
どこか悪いのでしょうか？

Sub エクスポート()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range(Cells(5, 7), Cells(79, 46)).Select
Selection.Copy 'ブックAの指定の範囲をコピー

Workbooks.Open Filename:="\\●●～パス～●●\ブックB.xlsm" '貼り付け先ファイルオープン

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'ブックBのシートBに値を貼り付け

　　On Error Resume Next

　　Range("A2:A60000").SpecialCells(xlCellTypeBlanks).Select
　　Selection.EntireRow.Delete

　　On Error GoTo 0 'ブックBのシートBのA列から空白行を探し出しその列全体を削除

ActiveWorkbook.Save '上書き保存

Windows("ブックA.xlsm").Activate
Range("B5").Select　　　　　　　　　　　　　　　　　　'ブックAに戻りB5をアクティブにする

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub

お忙しいところ恐縮ですが宜しくお願いします。