列の削除を早くしたい

質問

列の削除を自動化する次のマクロをおしえていただきました。
ずっと使っていましたが、異常に処理が遅いのです。
列の数は2370列以上あり、変動します。
行数は1から３３行までで、固定しています。
この行数の固定を加味して、もっと早く処理したいのですが、どうしたらよろしいでしょうか。

Sub 空白列の削除()
Dim UsedCell As Range
Dim Max_column, columnCount As Integer

'使用しているセルの範囲を取得します
Set UsedCell = ActiveSheet.UsedRange
'最大の行番号を取得します
Max_column = UsedCell.Cells(UsedCell.Count).Column
For columnCount = Max_column To 1 Step -1

'Worksheet関数のCountAを使ってデータの個数をカウント
If Application.WorksheetFunction.CountA(Columns(columnCount)) = 0 Then
'行の削除
Columns(columnCount).Delete
End If
Next
End Sub

回答No.2

ki-aaa · ベストアンサー

こんにちわ

これを試してください。

Sub 空白列の削除()
Dim UsedCell As Range
Dim Max_column As Long, columnCount As Long
Dim i As Long, j As Long
Dim 削除前配列 As Variant, 削除後配列 As Variant
Dim Max_gyo As Long
'使用しているセルの範囲を取得します
Set UsedCell = ActiveSheet.UsedRange
'最大の行番号を取得します
Max_column = UsedCell.Columns.Count
Max_gyo = UsedCell.Rows.Count
削除前配列 = UsedCell.Value
ReDim 削除後配列(1 To Max_gyo, 1 To Max_column)
i = 0
For columnCount = 1 To Max_column
'Worksheet関数のCountAを使ってデータの個数をカウント
If Application.WorksheetFunction.CountA(UsedCell.Columns(columnCount)) <> 0 Then
i = i + 1
For j = 1 To Max_gyo
削除後配列(j, i) = 削除前配列(j, columnCount)
Next j
End If
Next columnCount
UsedCell.ClearContents
UsedCell.Resize(Max_gyo, i).Value = 削除後配列
End Sub

それから、たまに間違った説明をしているのを見かけるのですが、
UsedRangeは、A列または、一行目がすべて空白だと、
"A1"からの領域ではないということを意識して、使用してください。

お礼

何ということでしょう！あの長い時間かっかった列の削除が一瞬にして実行できました。最初本当に削除したの？という疑いを持ったほどです。本当にありがとうございました。感謝感激です。ありがとうありがとう。

回答No.1

tom04

こんばんは！
あまりお役に立てないかもしれませんが、
お示しのコードでちゃんと動作するのであれば・・・

画面更新を止めてみてはどうでしょうか？

＞For columnCount = ・・・
の行の前に
＞Application.ScreenUpdating = False
を追加、

＞Next
の後に
＞Application.ScreenUpdating = True
を追加。

この程度しか思いつきませんが、時間短縮にならなかったらごめんなさいね。m(_ _)m

補足

ご指摘の件に関してはすでに試しております。できれば、最大行数が33であることを利用して速度をあげたいです。