Excel VBA 逆引き集 | ループ高速テンプレ（業務用）

Excel VBA
スポンサーリンク

ループ高速テンプレ（業務用）

大量データでも「待たない」ための本質は、セルへの個別アクセスを減らし、まとめて処理すること。ここでは業務でそのまま使える高速テンプレを目的別に整理し、初心者でも安全に使えるように落とし穴まで押さえます。

速度原則（最短で効くコア戦略）

  • セル直アクセス最小化: 配列へ一括読み込み→配列で計算→一括書き戻し。
  • 設定の一時停止: 画面更新、再計算、イベントを False/Manual にしてから処理。
  • 範囲を絞る: 最終行・必要列だけを対象に。CurrentRegionは空行で途切れる点に注意。
  • 対象集合で絞る: SpecialCells（可視・空白・数式・エラー）で事前に間引く。
  • 探索は辞書: VLOOKUPや重複判定を辞書に置き換えると桁違いに速い。
  • 書式は最後に最小回数: 値の処理後、必要最低限の書式適用だけを一括で。

安全高速ラップ（すべての重処理の土台）

Sub SpeedWrap_Basic()
    Dim scr As Boolean: scr = Application.ScreenUpdating
    Dim ev  As Boolean: ev  = Application.EnableEvents
    Dim calc As XlCalculation: calc = Application.Calculation
    On Error GoTo Cleanup

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    '=== 重い本処理（後続テンプレをここに差し込む） ===

Cleanup:
    Application.Calculation = calc
    Application.EnableEvents = ev
    Application.ScreenUpdating = scr
End Sub
VB
  • ポイント:
    • 復帰の保証: 失敗時も設定を元に戻す。
    • この中に各テンプレの「本処理」を入れて使い回す。

テンプレ1：配列一括（王道・最優先）

Sub LoopFast_ArrayBatch()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Dim last As Long: last = Cells(Rows.Count, "A").End(xlUp).Row
    Dim rg As Range: Set rg = Range("A2:D" & last)
    Dim v As Variant: v = rg.Value  '2次元配列へ読み込み

    Dim r As Long
    For r = 1 To UBound(v, 1)
        If IsNumeric(v(r, 3)) And IsNumeric(v(r, 4)) Then
            v(r, 2) = v(r, 3) * v(r, 4)  '金額=B（数量×単価）
        Else
            v(r, 2) = ""
        End If
    Next

    rg.Value = v  '一括書き戻し

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
  • ラベル:
    • 最速の定番: ループは配列上だけ、書き戻し1回。
    • 型安全: IsNumericやValで混在に備える。

テンプレ2：可視セルだけ行単位処理（重複防止）

Sub LoopFast_VisibleRows()
    Dim area As Range: Set area = Range("A1").CurrentRegion
    area.AutoFilter Field:=2, Criteria1:="営業A"

    Dim vis As Range
    On Error Resume Next
    Set vis = area.Offset(1).Resize(area.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not vis Is Nothing Then
        Dim c As Range
        For Each c In vis
            Cells(c.Row, "H").Value = Cells(c.Row, "C").Value * Cells(c.Row, "D").Value
        Next c
    End If
End Sub
VB
  • ラベル:
    • 列1本で回す: 同じ行を複数回処理する重複を回避。
    • 該当0件エラー: SpecialCellsはNothingチェックが必須。

テンプレ3：辞書で爆速ルックアップ（VLOOKUP代替）

Sub LoopFast_DictLookup()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    'マスタ辞書（コード→単価）
    Dim price As Object: Set price = CreateObject("Scripting.Dictionary")
    Dim mr As Long, r As Long
    mr = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To mr
        price(Worksheets("Master").Cells(r, "A").Value) = Worksheets("Master").Cells(r, "B").Value
    Next

    '明細は配列で一括処理
    Dim last As Long: last = Cells(Rows.Count, "C").End(xlUp).Row
    Dim rg As Range: Set rg = Range("C2:E" & last) 'C:コード D:数量 E:金額
    Dim v As Variant: v = rg.Value

    Dim i As Long, code As Variant, qty As Double
    For i = 1 To UBound(v, 1)
        code = v(i, 1)
        qty = Val(v(i, 2))
        If price.Exists(code) Then
            v(i, 3) = qty * price(code)
        Else
            v(i, 3) = ""
        End If
    Next
    rg.Value = v

Cleanup:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
  • ラベル:
    • O(1)検索: 10万〜100万件のマスタ照合に耐える。
    • 型統一: 文字列と数値のキー混在に注意（CStr/CLngで統一可）。

テンプレ4：条件集合で一括処理（SpecialCells）

Sub LoopFast_SpecialCells()
    '可視×空白を二段絞り → 一括で埋める
    Dim area As Range: Set area = Range("A1").CurrentRegion
    area.AutoFilter Field:=2, Criteria1:="営業A"

    Dim vis As Range, blanks As Range
    On Error Resume Next
    Set vis = area.Offset(1).Resize(area.Rows.Count - 1).Columns(5).SpecialCells(xlCellTypeVisible) 'E列
    Set blanks = vis.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not blanks Is Nothing Then blanks.Value = 0
End Sub
VB
  • ラベル:
    • 一括代入: 対象集合に対して処理1回。
    • 安全ガード: 二段ともNothingチェックを入れる。

テンプレ5：バッチ分割（10万行ずつ安定処理）

Sub LoopFast_Chunked()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim last As Long: last = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim size As Long: size = 100000

    Dim s As Long, e As Long
    For s = 2 To last Step size
        e = Application.Min(s + size - 1, last)
        Dim rg As Range: Set rg = ws.Range("A" & s & ":D" & e)
        Dim v As Variant: v = rg.Value

        Dim r As Long
        For r = 1 To UBound(v, 1)
            If IsNumeric(v(r, 3)) And IsNumeric(v(r, 4)) Then
                v(r, 2) = v(r, 3) * v(r, 4)
            Else
                v(r, 2) = ""
            End If
        Next
        rg.Value = v
    Next

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
VB
  • ラベル:
    • メモリ節約: 巨大範囲でも安定稼働。
    • 端切れ対応: Minで最終バッチを調整。

テンプレ6：Evaluateで列演算（VBAループ不要）

Sub LoopFast_Evaluate()
    Dim last As Long: last = Cells(Rows.Count, "C").End(xlUp).Row
    Range("E2:E" & last).Value = Evaluate("IF((C2:C" & last & ")*(D2:D" & last & ")>0,(C2:C" & last & ")*(D2:D" & last & "),"""")")
End Sub
VB
  • ラベル:
    • 式をまるごと: VBAのループを挟まず超高速。
    • 可読性: 複雑式は保守が難しいため、定番算式に限定して使う。

例題で練習（そのまま貼って動く）

'例題1：可視の「営業A」行だけ金額計算 → H列へ
Sub Example_VisibleSales()
    Dim area As Range: Set area = Range("A1").CurrentRegion
    area.AutoFilter Field:=2, Criteria1:="営業A"
    Dim vis As Range
    On Error Resume Next
    Set vis = area.Offset(1).Resize(area.Rows.Count - 1).Columns(1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not vis Is Nothing Then
        Dim c As Range
        For Each c In vis
            Cells(c.Row, "H").Value = Cells(c.Row, "C").Value * Cells(c.Row, "D").Value
        Next c
    End If
End Sub

'例題2：数式列Eだけ値化（該当セルのみに一括）
Sub Example_FormulasToValues()
    Dim f As Range
    On Error Resume Next
    Set f = Range("E2:E200000").SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    If Not f Is Nothing Then f.Value = f.Value
End Sub

'例題3：商品コード→単価の辞書で爆速ルックアップ
Sub Example_FastLookup()
    Dim price As Object: Set price = CreateObject("Scripting.Dictionary")
    Dim mLast As Long, r As Long
    mLast = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
    For r = 2 To mLast
        price(Worksheets("Master").Cells(r, "A").Value) = Worksheets("Master").Cells(r, "B").Value
    Next

    Dim last As Long: last = Cells(Rows.Count, "C").End(xlUp).Row
    Dim rg As Range: Set rg = Range("C2:E" & last)
    Dim v As Variant: v = rg.Value
    Dim i As Long
    For i = 1 To UBound(v, 1)
        Dim code As Variant: code = v(i, 1)
        Dim qty As Double: qty = Val(v(i, 2))
        If price.Exists(code) Then v(i, 3) = qty * price(code)
    Next
    rg.Value = v
End Sub
VB

落とし穴と対策チェックリスト

  • 設定復帰忘れ:
    • 対策: 退避→Cleanupで必ず復帰。EnableEvents/Calculation/ScreenUpdatingの三点セット。
  • CurrentRegionの途切れ:
    • 対策: 空行があると切れる。最終行・列から明示的に範囲を組む。
  • SpecialCellsの0件エラー:
    • 対策: On Error＋Nothingチェックをテンプレ化。
  • 型混在で計算失敗:
    • 対策: IsNumeric/Val/CStrで防御。空文字やスペースはTrimも併用。
  • 同じ行の重複処理:
    • 対策: 可視行のループは列1本に限定し、Rowで横展開。
  • 数式消失の意図確認:
    • 対策: 値化が目的か要確認。必要なら .Formula を退避。
  • 書式の重さ:
    • 対策: 値処理→対象範囲を特定→最小回数で一括適用。
スポンサーリンク
タイトルとURLをコピーしました