Excel VBA 複数「列」を高速削除「Range・Union」使用で高速化する

複数「列」を削除高速化
1. ①元データ
2. ②処理後データ
処理速度の違い
サンプル①
サンプル②　高速化
サンプル③　さらに高速化したコード（配列判定方式）
1. 改善ポイント
免責事項

複数「列」を削除高速化

うさこちゃん

条件に合う列を高速に削除したい場合にデータ量が大量にあると非常に削除が(かなり)遅い場合があります。
その場合は「Range」に削除データを貯めておいて一括して削除すると高速化できます。

①元データ

うさこちゃん

2行目に０のデータがある列を削除する。

ヘッダ	1	2	3	4	5	6	7	8	9	10	11
条件	2	1	0	1	5	0	0	5	0	1	0
データ	データ	データ	データ	データ	データ	データ	データ	データ	データ	データ	データ

②処理後データ

うさこちゃん

2行目の０のデータを列削除した結果。

ヘッダ	1	2	4	5	8	10
条件	2	1	1	5	5	1
データ	データ	データ	データ	データ	データ	データ

処理速度の違い

うさこちゃん

今回は以下のデータ件数で約１０倍の速度差になりました。
列データ５００件
行データ１００件
削除対象１００件

サンプル①	0.5273
サンプル②	0.0625

サンプル①

Dim ObjThisSh  As Object
Dim LngColMax As Long
Set ObjThisSh = ThisWorkbook.Sheets("Sheet1")

With ObjThisSh

    LngColMax = .Cells(2, .Columns.Count).End(xlToLeft).Column

    For LngIndex = 2 To LngColMax
        If .Cells(2, LngIndex).Value = 0 Then
            '列を削除
            .Columns(LngIndex).Delete
        End If
    Next LngIndex

End With

サンプル②　高速化

Dim ObjThisSh  As Object
Dim LngColMax As Long
Dim LngIndex As Long
Dim RngDelete As Range
Set ObjThisSh = ThisWorkbook.Sheets("Sheet1")

With ObjThisSh

    LngColMax = .Cells(2, .Columns.Count).End(xlToLeft).Column

    For LngIndex = 2 To LngColMax
        If .Cells(2, LngIndex).Value = 0 Then
            If RngDelete Is Nothing Then
                Set RngDelete = .Cells(2, LngIndex)
            Else
                Set RngDelete = Union(RngDelete, .Cells(2, LngIndex))
            End If
        End If
    Next LngIndex

    If Not RngDelete Is Nothing Then
        'RngDelete.EntireColumn.Select 'テスト用　削除予定列を表示させる
        '列を一括削除
        RngDelete.EntireColumn.Delete
    End If

End With

サンプル③　さらに高速化したコード（配列判定方式）

改善ポイント

VarValues = Range(...).Value で行2を一気に配列化。
→ .Cells() を何度も参照しないので 劇的に高速化。
判定は配列内で完結するため、Excelとのやり取り（COM呼び出し）が最小限。
最後にまとめて Delete 実行。

Dim ObjThisSh  As Object
Dim LngColMax  As Long
Dim LngIndex   As Long
Dim RngDelete  As Range
Dim VarValues  As Variant

Set ObjThisSh = ThisWorkbook.Sheets("Sheet1")

With ObjThisSh
    ' 行2を配列に読み込み
    LngColMax = .Cells(2, .Columns.Count).End(xlToLeft).Column
    VarValues = .Range(.Cells(2, 2), .Cells(2, LngColMax)).Value

    ' 配列で判定（For文はセルにアクセスしないので速い）
    For LngIndex = 1 To UBound(VarValues, 2)
        If VarValues(1, LngIndex) = 0 Then
            If RngDelete Is Nothing Then
                Set RngDelete = .Cells(2, LngIndex + 1)
            Else
                Set RngDelete = Union(RngDelete, .Cells(2, LngIndex + 1))
            End If
        End If
    Next LngIndex

    ' 一括削除
    If Not RngDelete Is Nothing Then
        RngDelete.EntireColumn.Delete
    End If
End With