Excelマクロの処理が途中で止まる・フリーズする原因と高速化の対処法

「Excelマクロを実行したら途中で固まってしまった」「数千行のデータを処理させたら何分待っても終わらない」「応答なしになってExcelが強制終了するしかなかった」――こうしたトラブルは、VBAを実務で使い始めた段階で必ずぶつかる壁です。原因は処理の設計・セルへのアクセス方法・画面更新・計算設定など複数にわたりますが、正しい対処を知れば数十分かかっていた処理が数秒で終わることも珍しくありません。本記事では、マクロが止まる・重くなる原因をすべて体系的に解説し、その場でコピーして使える高速化コードとともに徹底的に解説します。

処理が重くなる・止まる原因の全体像
対策1：画面更新・計算・イベントを止める（最重要）
対策2：セルへのアクセス回数を最小化する（最大の高速化ポイント）
対策3：ループ処理の最適化
対策4：SelectとActivateを排除する
対策5：FindとReplaceを活用してループを減らす
対策6：DoEventsでフリーズを防ぐ
対策7：進捗バーで「止まっているように見える」問題を解決する
対策8：メモリ管理とオブジェクトの解放
対策9：タイムアウト処理で無限ループを防ぐ
処理時間を計測するベンチマークコード
高速化設定の標準テンプレート
処理が重い・止まる原因チェックリスト
まとめ

処理が重くなる・止まる原因の全体像

マクロの処理が遅くなる・止まる原因は、大きく分けると次の5つのカテゴリに集約されます。

画面描画のオーバーヘッド：セルの値を変更するたびに画面が再描画される。大量のセル操作では描画コストが処理全体の大半を占める
セルへの過剰なアクセス：ループの中でセルを1つずつ読み書きするのは最も遅い処理の典型。1万回のセルアクセスは配列経由での処理に比べて100倍以上遅くなることがある
自動計算の連鎖：セルを変更するたびにExcelが全シートの数式を再計算する。大量のVLOOKUP・IF・SUMIF式が入ったシートでは1セルの変更が数秒の待ち時間を生む
無駄なSelect・Activate：マクロ記録で生成されるコードに多く含まれる。オブジェクトを切り替えるたびに内部コストが発生する
無限ループ・論理バグ：終了条件が満たされないループが永遠に回り続けてフリーズしているように見える

まず後述の「高速化設定テンプレート」を処理の前後に追加するだけで、多くのケースで劇的な速度改善が得られます。それでも遅い場合は、セルアクセスのパターンを配列に変更することで、さらに大幅な高速化が実現します。

対策1：画面更新・計算・イベントを止める（最重要）

マクロ高速化で最も簡単かつ効果が大きいのが、処理中の画面更新・自動計算・イベント処理を一時停止することです。これだけで処理速度が数倍〜数十倍改善するケースがあります。

3つの設定と効果

Application.ScreenUpdating = False：画面の再描画を停止する。セルの値変更・書式変更・スクロールなど、あらゆる描画処理が省略される。処理後は必ず True に戻す
Application.Calculation = xlCalculationManual：自動計算を手動計算に切り替える。セル変更のたびに数式が再計算されなくなる。処理後は xlCalculationAutomatic に戻す
Application.EnableEvents = False：Worksheet_ChangeなどのイベントプロシージャをVBAから操作したときに発動しないようにする。処理後は True に戻す

' ========================================
' 高速化設定のON/OFF（最も基本的なテンプレート）
' ========================================

Sub HighSpeedProcess()

    ' --- 高速化設定 ---
    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual
    Application.EnableEvents   = False
    Application.DisplayAlerts  = False   ' 確認ダイアログも抑制

    On Error GoTo ErrorHandler

    ' ===== ここにメイン処理を書く =====

    Dim ws      As Worksheet
    Dim lastRow As Long
    Dim i       As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For i = 2 To lastRow
        ws.Cells(i, 3).Value = ws.Cells(i, 1).Value * ws.Cells(i, 2).Value
    Next i

    ' ===================================

    GoTo CleanUp

ErrorHandler:
    MsgBox "エラーが発生しました。" & vbCrLf & _
           "番号: " & Err.Number & vbCrLf & _
           "内容: " & Err.Description, vbCritical

CleanUp:
    ' --- 設定を元に戻す（エラー時も必ず実行） ---
    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.EnableEvents   = True
    Application.DisplayAlerts  = True
    Application.StatusBar      = False   ' ステータスバーもリセット

    Set ws = Nothing

End Sub

設定を元に戻し忘れたときの緊急復旧マクロ

' ========================================
' 設定が元に戻らなくなったときの緊急復旧マクロ
' Alt+F8から実行するか、クイックアクセスツールバーに登録する
' ========================================
Sub ResetExcelSettings()

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.EnableEvents   = True
    Application.DisplayAlerts  = True
    Application.CutCopyMode    = False
    Application.StatusBar      = False
    Application.Cursor         = xlDefault

    MsgBox "Excelの設定をリセットしました。", vbInformation

End Sub

対策2：セルへのアクセス回数を最小化する（最大の高速化ポイント）

VBAにおけるパフォーマンスの最大のボトルネックは、ループ内でセルを1つずつ読み書きすることです。Excelのセルへのアクセスは内部的にCOMインターフェースを介するため、1回のアクセスごとに大きなオーバーヘッドが発生します。1万行のデータを処理するとき、ループでセルを1つずつ読み書きするのと、一度に配列に読み込んで処理するのとでは、100倍以上の速度差が生まれることがあります。

セルアクセスを配列に置き換える基本パターン

' ========================================
' NG：ループ内でセルを1つずつ読み書きする（遅い）
' ========================================
Sub SlowCellAccess()

    Dim ws      As Worksheet
    Dim i       As Long
    Dim lastRow As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = 10000

    Application.ScreenUpdating = False

    ' 1万回のセルアクセスが発生する → 遅い
    For i = 1 To lastRow
        ws.Cells(i, 3).Value = ws.Cells(i, 1).Value * ws.Cells(i, 2).Value
    Next i

    Application.ScreenUpdating = True
    Set ws = Nothing

End Sub

' ========================================
' OK：配列経由で一括処理する（高速）
' セルの読み取り1回・書き込み1回だけ
' ========================================
Sub FastArrayAccess()

    Dim ws       As Worksheet
    Dim lastRow  As Long
    Dim srcData  As Variant   ' 読み込み用配列
    Dim results  As Variant   ' 書き込み用配列
    Dim i        As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    ' 1回でA列・B列のデータを配列に読み込む
    srcData = ws.Range("A1:B" & lastRow).Value
    ' srcData(行, 1) = A列の値
    ' srcData(行, 2) = B列の値

    ' 書き込み用配列を準備
    ReDim results(1 To lastRow, 1 To 1)

    ' 配列内で計算（セルアクセスなし）
    For i = 1 To lastRow
        If IsNumeric(srcData(i, 1)) And IsNumeric(srcData(i, 2)) Then
            results(i, 1) = srcData(i, 1) * srcData(i, 2)
        Else
            results(i, 1) = 0
        End If
    Next i

    ' 1回でC列に一括書き込み
    ws.Range("C1:C" & lastRow).Value = results

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Set ws = Nothing

    MsgBox "処理完了（配列方式）", vbInformation

End Sub

複数列を一括で読み書きする実践パターン

' ========================================
' 複数列の読み込み・加工・書き込みを配列で行う実践パターン
' ========================================
Sub MultiColumnArrayProcess()

    Dim ws         As Worksheet
    Dim lastRow    As Long
    Dim srcData    As Variant
    Dim outData    As Variant
    Dim i          As Long

    Set ws      = ThisWorkbook.Sheets("データ")
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

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

    ' A〜E列を一括読み込み（2行目から最終行）
    srcData = ws.Range("A2:E" & lastRow).Value

    ' 出力用配列（3列：合計・平均・判定）
    ReDim outData(1 To UBound(srcData, 1), 1 To 3)

    For i = 1 To UBound(srcData, 1)

        Dim v1 As Double, v2 As Double, v3 As Double
        v1 = IIf(IsNumeric(srcData(i, 3)), CDbl(srcData(i, 3)), 0)
        v2 = IIf(IsNumeric(srcData(i, 4)), CDbl(srcData(i, 4)), 0)
        v3 = IIf(IsNumeric(srcData(i, 5)), CDbl(srcData(i, 5)), 0)

        outData(i, 1) = v1 + v2 + v3           ' F列：合計
        outData(i, 2) = (v1 + v2 + v3) / 3     ' G列：平均
        outData(i, 3) = IIf(outData(i, 1) >= 60, "合格", "不合格")   ' H列：判定

    Next i

    ' F〜H列に一括書き込み
    ws.Range("F2:H" & lastRow).Value = outData

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.EnableEvents   = True

    Set ws = Nothing
    MsgBox "処理完了", vbInformation

End Sub

速度比較：ループ vs 配列の目安

1,000行：ループ方式約2〜5秒 → 配列方式 0.1秒未満
10,000行：ループ方式約30〜120秒 → 配列方式約1秒
100,000行：ループ方式数十分〜タイムアウト → 配列方式約5〜10秒

対策3：ループ処理の最適化

ループ処理自体を最適化することでも大きな速度改善が得られます。特に「ループの外に出せる処理をループ内に書いている」パターンが多く、これを修正するだけで処理時間が数分の一になることがあります。

ループ内の無駄を排除する

' ========================================
' NG：ループのたびに最終行を取得している（遅い）
' ========================================
Sub SlowLoop()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)

    Dim i As Long
    For i = 1 To 10000
        ' ループのたびにEnd(xlUp).Rowを呼んでいる → 毎回セルアクセス発生
        Dim lastRow As Long
        lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

        If i <= lastRow Then
            ws.Cells(i, 2).Value = ws.Cells(i, 1).Value * 1.1
        End If
    Next i

    Set ws = Nothing

End Sub

' ========================================
' OK：ループの外で最終行を1度だけ取得する
' ========================================
Sub FastLoop()

    Dim ws      As Worksheet
    Dim lastRow As Long
    Dim i       As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row   ' ループ前に1回だけ取得

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    For i = 1 To lastRow
        ws.Cells(i, 2).Value = ws.Cells(i, 1).Value * 1.1
    Next i

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Set ws = Nothing

End Sub

' ========================================
' For Each vs For i：コレクション操作の最適化
' ========================================

' NG：全セルにFor Eachでアクセスする（非常に遅い）
Sub SlowForEach()

    Dim cell As Range
    For Each cell In ActiveSheet.UsedRange
        If cell.Value > 100 Then
            cell.Interior.Color = vbYellow
        End If
    Next cell

End Sub

' OK：条件に合う処理はSpecialCells・AutoFilter・配列で代替する
Sub FastConditionalFormat()

    Dim ws      As Worksheet
    Dim data    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim lastRow As Long
    Dim lastCol As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.UsedRange.Rows.Count
    lastCol     = ws.UsedRange.Columns.Count

    Application.ScreenUpdating = False

    ' 書式のみの操作であればワークシート関数・条件付き書式で代替
    ' 値の判定が必要な場合は配列で一括取得して条件分岐
    data = ws.UsedRange.Value

    ' 値が100超のセルだけアドレスを収集して一括で書式設定
    Dim targetAddresses As String
    targetAddresses = ""

    For i = 1 To UBound(data, 1)
        For j = 1 To UBound(data, 2)
            If IsNumeric(data(i, j)) Then
                If CDbl(data(i, j)) > 100 Then
                    If Len(targetAddresses) > 0 Then targetAddresses = targetAddresses & ","
                    targetAddresses = targetAddresses & _
                        ws.Cells(i + ws.UsedRange.Row - 1, j + ws.UsedRange.Column - 1).Address
                End If
            End If
        Next j
    Next i

    ' 一括で書式設定（Union使用版はさらに高速）
    If Len(targetAddresses) > 0 Then
        ws.Range(targetAddresses).Interior.Color = vbYellow
    End If

    Application.ScreenUpdating = True
    Set ws = Nothing

End Sub

' ========================================
' Unionを使って複数セルをまとめて書式設定する高速パターン
' ========================================
Sub FastUnionFormat()

    Dim ws          As Worksheet
    Dim data        As Variant
    Dim targetRange As Range
    Dim i           As Long
    Dim j           As Long

    Set ws   = ThisWorkbook.Sheets(1)
    data     = ws.UsedRange.Value

    Application.ScreenUpdating = False

    For i = 1 To UBound(data, 1)
        For j = 1 To UBound(data, 2)
            If IsNumeric(data(i, j)) Then
                If CDbl(data(i, j)) > 100 Then
                    Dim cel As Range
                    Set cel = ws.Cells(i + ws.UsedRange.Row - 1, _
                                       j + ws.UsedRange.Column - 1)
                    If targetRange Is Nothing Then
                        Set targetRange = cel
                    Else
                        Set targetRange = Union(targetRange, cel)
                    End If
                End If
            End If
        Next j
    Next i

    ' まとめて1回だけ書式設定
    If Not targetRange Is Nothing Then
        targetRange.Interior.Color = vbYellow
    End If

    Application.ScreenUpdating = True

    Set targetRange = Nothing
    Set ws          = Nothing

End Sub

対策4：SelectとActivateを排除する

マクロの記録機能で生成されたコードには Select と Activate が大量に含まれています。これらはシートやセルをアクティブにする操作で、実行のたびに画面フォーカスの切り替えコストが発生します。SelectとActivateを排除し、オブジェクト変数を直接操作するだけで処理速度が大幅に改善します。

' ========================================
' NG：マクロ記録そのまま（SelectとActivateだらけ）
' ========================================
Sub MacroRecordedCode()

    Sheets("データ").Select
    Range("A1").Select
    Selection.Copy
    Sheets("集計").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[100]C)"

    Sheets("データ").Select
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft

    Range("A1").Select

End Sub

' ========================================
' OK：SelectとActivateを完全に排除した高速版
' ========================================
Sub OptimizedCode()

    Dim wsSrc  As Worksheet
    Dim wsDest As Worksheet

    Set wsSrc  = ThisWorkbook.Sheets("データ")
    Set wsDest = ThisWorkbook.Sheets("集計")

    Application.ScreenUpdating = False

    ' コピー元→コピー先を1行で記述（Select不要）
    wsSrc.Range("A1").Copy Destination:=wsDest.Range("A1")
    Application.CutCopyMode = False

    ' 数式の設定（Select不要）
    wsDest.Range("B1").FormulaR1C1 = "=SUM(R[1]C:R[100]C)"

    ' 列の削除（Select不要）
    wsSrc.Columns("C:C").Delete Shift:=xlToLeft

    Application.ScreenUpdating = True

    Set wsSrc  = Nothing
    Set wsDest = Nothing

End Sub

対策5：FindとReplaceを活用してループを減らす

「特定の値を持つ行を探す」「特定の文字列を置換する」という処理は、ループで1行ずつ確認するよりも Find メソッドや Replace メソッドを使う方が圧倒的に高速です。これらはExcelの内部エンジンで処理されるため、VBAのループより大幅に速く動作します。

' ========================================
' NG：ループで特定値を探す（遅い）
' ========================================
Sub SlowSearch()

    Dim ws      As Worksheet
    Dim i       As Long
    Dim lastRow As Long
    Dim keyword As String

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    keyword     = "対象"

    For i = 1 To lastRow
        If ws.Cells(i, 1).Value = keyword Then
            ws.Cells(i, 2).Value = "処理済"
        End If
    Next i

    Set ws = Nothing

End Sub

' ========================================
' OK：FindNextで高速検索
' ========================================
Sub FastSearch()

    Dim ws        As Worksheet
    Dim searchRng As Range
    Dim foundCell As Range
    Dim firstAddr As String
    Dim keyword   As String

    Set ws        = ThisWorkbook.Sheets(1)
    Set searchRng = ws.Range("A:A")
    keyword       = "対象"

    Application.ScreenUpdating = False

    Set foundCell = searchRng.Find( _
                       What:=keyword, _
                       LookIn:=xlValues, _
                       LookAt:=xlWhole)

    If foundCell Is Nothing Then
        MsgBox "「" & keyword & "」は見つかりませんでした。", vbInformation
        GoTo CleanUp
    End If

    firstAddr = foundCell.Address

    Do
        foundCell.Offset(0, 1).Value = "処理済"
        Set foundCell = searchRng.FindNext(foundCell)
        If foundCell Is Nothing Then Exit Do
    Loop While foundCell.Address <> firstAddr

CleanUp:
    Application.ScreenUpdating = True
    Set foundCell = Nothing
    Set searchRng = Nothing
    Set ws        = Nothing

End Sub

' ========================================
' 文字列置換もReplaceメソッドで一括処理（ループ不要）
' ========================================
Sub FastReplace()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)

    Application.ScreenUpdating = False

    ' A列全体の「旧社名」を「新社名」に一括置換
    ws.Columns("A:A").Replace _
        What:="旧社名株式会社", _
        Replacement:="新社名株式会社", _
        LookAt:=xlPart, _
        MatchCase:=False

    ' 複数列をまとめて置換
    ws.UsedRange.Replace _
        What:="　",   _   ' 全角スペース
        Replacement:=" ", _  ' 半角スペース
        LookAt:=xlPart

    Application.ScreenUpdating = True
    Set ws = Nothing

    MsgBox "置換完了", vbInformation

End Sub

対策6：DoEventsでフリーズを防ぐ

長時間の処理を実行中、Excelが「応答なし」状態になってユーザーが何も操作できなくなることがあります。これはVBAが処理を独占してWindowsのイベントキュー（画面更新・マウス操作・キー入力）を処理する機会を与えないために起きます。DoEvents を適切な間隔で呼び出すことでこの問題を解消できます。

DoEventsの使い方

' ========================================
' DoEventsでフリーズを防ぐパターン
' ========================================
Sub LongProcessWithDoEvents()

    Dim ws      As Worksheet
    Dim i       As Long
    Dim lastRow As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = 100000

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    For i = 1 To lastRow

        ' メイン処理
        ws.Cells(i, 2).Value = ws.Cells(i, 1).Value & "_処理済"

        ' 1000行ごとにDoEventsを呼んでWindowsに制御を渡す
        ' 毎ループ呼ぶと逆に遅くなるので間引いて呼ぶ
        If i Mod 1000 = 0 Then
            DoEvents
            Application.StatusBar = "処理中... " & i & " / " & lastRow & _
                                     " (" & Int(i / lastRow * 100) & "%)"
        End If

    Next i

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.StatusBar      = False

    Set ws = Nothing
    MsgBox "処理完了", vbInformation

End Sub

DoEventsとEscキーによる中断処理

' ========================================
' DoEvents + Escキーで処理を途中でキャンセルできるパターン
' ========================================
Sub CancellableProcess()

    Dim ws        As Worksheet
    Dim i         As Long
    Dim lastRow   As Long
    Dim cancelled As Boolean

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    cancelled   = False

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

    ' キャンセル用：Escキーを有効にする
    Application.EnableCancelKey = xlErrorHandler

    On Error GoTo UserCancelled

    For i = 1 To lastRow

        ' メイン処理
        ws.Cells(i, 3).Value = ws.Cells(i, 1).Value * ws.Cells(i, 2).Value

        ' 500行ごとに進捗更新とDoEvents
        If i Mod 500 = 0 Then
            Application.StatusBar = "処理中 " & i & "/" & lastRow & _
                                     "  Escキーでキャンセル"
            DoEvents
        End If

    Next i

    GoTo ProcessComplete

UserCancelled:
    If Err.Number = 18 Then   ' Escキーによるキャンセル
        cancelled = True
        Err.Clear
    End If

ProcessComplete:
    ' 必ずリセット
    Application.EnableCancelKey = xlInterrupt   ' Escキーを元の動作に戻す
    Application.ScreenUpdating  = True
    Application.Calculation     = xlCalculationAutomatic
    Application.EnableEvents    = True
    Application.StatusBar       = False

    If cancelled Then
        MsgBox "処理がキャンセルされました。" & vbCrLf & _
               i & "行目まで処理しました。", vbInformation
    Else
        MsgBox "処理完了（全 " & lastRow & " 行）", vbInformation
    End If

    Set ws = Nothing

End Sub

対策7：進捗バーで「止まっているように見える」問題を解決する

処理が実際には動いているのに画面が固まって見えるとき、ユーザーは「フリーズした」と判断してExcelを強制終了してしまいます。ステータスバーやユーザーフォームを使った進捗表示を追加することで、処理が動いていることをユーザーに伝え、誤った強制終了を防ぐことができます。

ステータスバーを使った進捗表示

' ========================================
' ステータスバーで進捗を表示するパターン
' ========================================
Sub ProcessWithStatusBar()

    Dim ws      As Worksheet
    Dim i       As Long
    Dim lastRow As Long
    Dim startTime As Single

    Set ws        = ThisWorkbook.Sheets(1)
    lastRow       = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    startTime     = Timer   ' 処理開始時刻を記録

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    For i = 1 To lastRow

        ' メイン処理
        ws.Cells(i, 2).Value = ws.Cells(i, 1).Value

        ' 200行ごとに進捗を更新
        If i Mod 200 = 0 Or i = lastRow Then

            Dim pct      As Long
            Dim elapsed  As Single
            Dim remaining As Single

            pct      = Int(i / lastRow * 100)
            elapsed  = Timer - startTime

            ' 残り時間の推定
            If pct > 0 Then
                remaining = elapsed / pct * (100 - pct)
            Else
                remaining = 0
            End If

            Application.StatusBar = "処理中 " & i & "/" & lastRow & _
                                     " (" & pct & "%)" & _
                                     "  経過:" & Format(elapsed, "0.0") & "秒" & _
                                     "  残り:" & Format(remaining, "0.0") & "秒"
            DoEvents

        End If

    Next i

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.StatusBar      = False

    Dim totalTime As Single
    totalTime = Timer - startTime
    MsgBox "処理完了！" & vbCrLf & "処理時間: " & Format(totalTime, "0.00") & " 秒", vbInformation

    Set ws = Nothing

End Sub

セルのプログレスバーで視覚的な進捗を表示する

' ========================================
' セルをプログレスバーとして使う視覚的な進捗表示
' ========================================
Sub ProcessWithCellProgressBar()

    Dim ws        As Worksheet
    Dim wsProgress As Worksheet
    Dim i         As Long
    Dim lastRow   As Long
    Dim pct       As Long
    Dim barLength As Long

    Set ws = ThisWorkbook.Sheets(1)
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' 進捗バー用セルを準備（A1セルに表示）
    barLength = 20   ' バーの長さ（文字数）

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    For i = 1 To lastRow

        ws.Cells(i, 2).Value = ws.Cells(i, 1).Value * 2

        If i Mod 500 = 0 Or i = lastRow Then

            pct = Int(i / lastRow * 100)
            Dim filled As Long
            filled = Int(barLength * pct / 100)

            Dim bar As String
            bar = "[" & String(filled, "■") & String(barLength - filled, "□") & "]" & _
                  " " & pct & "% (" & i & "/" & lastRow & ")"

            ' ステータスバーに表示
            Application.StatusBar = "処理中: " & bar

            ' スクリーン更新を一時的にオンにしてバーを描画
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False

            DoEvents

        End If

    Next i

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.StatusBar      = False

    Set ws = Nothing
    MsgBox "完了！", vbInformation

End Sub

対策8：メモリ管理とオブジェクトの解放

大量のオブジェクトを作成・保持し続けると、メモリが逼迫してExcelが極端に遅くなったり、クラッシュすることがあります。特に大量の Range オブジェクトや外部ライブラリのオブジェクト（ADODB・FSO等）を使う場合は、使い終わったら必ず Set obj = Nothing で解放することが重要です。

' ========================================
' メモリ効率の良い大量データ処理パターン
' ========================================
Sub MemoryEfficientProcess()

    Dim ws       As Worksheet
    Dim chunk    As Long   ' 一度に処理する行数
    Dim startRow As Long
    Dim endRow   As Long
    Dim lastRow  As Long

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    chunk       = 5000     ' 5000行ずつ分割処理

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    startRow = 2   ' ヘッダーをスキップ

    Do While startRow <= lastRow

        endRow = Application.Min(startRow + chunk - 1, lastRow)

        ' チャンク分のデータを読み込んで処理
        Dim srcData As Variant
        Dim outData As Variant

        srcData = ws.Range("A" & startRow & ":B" & endRow).Value
        ReDim outData(1 To UBound(srcData, 1), 1 To 1)

        Dim i As Long
        For i = 1 To UBound(srcData, 1)
            Dim v1 As Double, v2 As Double
            v1 = IIf(IsNumeric(srcData(i, 1)), CDbl(srcData(i, 1)), 0)
            v2 = IIf(IsNumeric(srcData(i, 2)), CDbl(srcData(i, 2)), 0)
            outData(i, 1) = v1 + v2
        Next i

        ' 書き込み
        ws.Range("C" & startRow & ":C" & endRow).Value = outData

        ' チャンク処理後にアレイをリセットしてメモリを解放
        Erase srcData
        Erase outData

        ' 進捗表示
        Application.StatusBar = "処理中: " & endRow & "/" & lastRow & " 行完了"
        DoEvents

        startRow = endRow + 1

    Loop

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.StatusBar      = False

    Set ws = Nothing
    MsgBox "チャンク処理完了（" & lastRow - 1 & " 行）", vbInformation

End Sub

' ========================================
' オブジェクト変数の解放チェック用テンプレート
' ========================================
Sub ProperObjectRelease()

    Dim ws1  As Worksheet
    Dim ws2  As Worksheet
    Dim rng  As Range
    Dim conn As Object
    Dim rs   As Object

    On Error GoTo CleanUp

    Set ws1  = ThisWorkbook.Sheets(1)
    Set ws2  = ThisWorkbook.Sheets(2)
    Set rng  = ws1.Range("A1:Z1000")
    Set conn = CreateObject("ADODB.Connection")
    Set rs   = CreateObject("ADODB.Recordset")

    ' ===== メイン処理 =====

    ' =====================

    GoTo CleanUp

CleanUp:
    ' 使用したオブジェクトを逆順にすべて解放
    If Not rs   Is Nothing Then If rs.State   = 1 Then rs.Close
    If Not conn Is Nothing Then If conn.State = 1 Then conn.Close

    Set rs   = Nothing
    Set conn = Nothing
    Set rng  = Nothing
    Set ws2  = Nothing
    Set ws1  = Nothing

End Sub

対策9：タイムアウト処理で無限ループを防ぐ

終了条件を誤って書いたループが永遠に回り続けると、Excelが応答なしになります。特にWebアクセスや外部ファイルの待機処理、Do WhileループでEOF判定を忘れたケースなどで起きやすいです。タイムアウト処理を入れることで、想定外の無限ループを自動的に終了させることができます。

' ========================================
' タイムアウト付きループのパターン
' ========================================
Sub LoopWithTimeout()

    Dim startTime   As Single
    Dim timeoutSec  As Single
    Dim i           As Long

    startTime  = Timer
    timeoutSec = 30   ' 30秒でタイムアウト

    ' 外部処理の完了待ちループ（例：ファイルの生成待ち）
    Dim targetFile As String
    targetFile = ThisWorkbook.Path & "\output.csv"

    Do While Dir(targetFile) = ""

        ' タイムアウトチェック
        If Timer - startTime > timeoutSec Then
            MsgBox "タイムアウト：" & timeoutSec & "秒以内にファイルが生成されませんでした。", _
                   vbCritical
            Exit Sub
        End If

        ' 0.5秒待機してから再チェック
        Application.Wait Now + TimeValue("00:00:01") * 0.5
        DoEvents

    Loop

    MsgBox "ファイルが生成されました: " & targetFile, vbInformation

End Sub

' ========================================
' Do Whileループの安全な書き方（EOF忘れ防止）
' ========================================
Sub SafeFileReadLoop()

    Dim fileNo   As Integer
    Dim lineText As String
    Dim count    As Long
    Dim maxLines As Long

    fileNo   = FreeFile()
    maxLines = 1000000   ' 最大100万行でタイムアウト

    Open ThisWorkbook.Path & "\data.csv" For Input As #fileNo

    count = 0

    Do While Not EOF(fileNo)

        Line Input #fileNo, lineText
        ' 処理
        count = count + 1

        ' 異常に多い行数でループを強制終了
        If count > maxLines Then
            MsgBox "処理行数が上限（" & maxLines & "行）を超えました。処理を中断します。", _
                   vbExclamation
            Exit Do
        End If

    Loop

    Close #fileNo
    Debug.Print "処理行数: " & count

End Sub

処理時間を計測するベンチマークコード

高速化の効果を数値で確認するため、処理前後で時間を計測するベンチマークを実装しましょう。Timer 関数（秒単位）と GetTickCount API（ミリ秒単位）の2種類があります。

' ========================================
' Timer関数を使ったシンプルなベンチマーク
' ========================================
Sub BenchmarkWithTimer()

    Dim startTime As Single
    Dim endTime   As Single
    Dim elapsed   As Single

    startTime = Timer   ' 処理開始時刻（秒）

    ' ===== 計測対象の処理 =====
    Dim ws As Worksheet
    Dim i  As Long
    Set ws = ThisWorkbook.Sheets(1)

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    For i = 1 To 10000
        ws.Cells(i, 1).Value = i
    Next i

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    ' ==========================

    endTime = Timer
    elapsed = endTime - startTime

    Set ws = Nothing
    MsgBox "処理時間: " & Format(elapsed, "0.000") & " 秒", vbInformation

End Sub

' ========================================
' ミリ秒精度のベンチマーク（Windows API使用）
' ========================================
#If VBA7 Then
    Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
    Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If

Sub BenchmarkMillisecond()

    Dim startMs As Long
    Dim endMs   As Long
    Dim elapsed As Long

    startMs = GetTickCount()   ' 開始時刻（ミリ秒）

    ' ===== 計測対象の処理 =====
    Dim ws  As Worksheet
    Dim arr As Variant
    Dim i   As Long

    Set ws = ThisWorkbook.Sheets(1)
    ReDim arr(1 To 10000, 1 To 1)

    For i = 1 To 10000
        arr(i, 1) = i
    Next i

    ws.Range("A1:A10000").Value = arr
    ' ==========================

    endMs   = GetTickCount()
    elapsed = endMs - startMs

    Set ws = Nothing
    MsgBox "処理時間: " & elapsed & " ミリ秒 (" & Format(elapsed / 1000, "0.000") & " 秒)", _
           vbInformation

End Sub

' ========================================
' 複数処理の速度を比較するベンチマークフレームワーク
' ========================================
Sub CompareBenchmarks()

    Dim results() As String
    ReDim results(1 To 3, 1 To 2)

    Dim startTime As Single

    ' --- テスト1：ループでセルに1つずつ書き込む ---
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear

    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual

    startTime = Timer
    Dim i As Long
    For i = 1 To 5000
        ws.Cells(i, 1).Value = i
    Next i
    results(1, 1) = "ループ（セル直書き）"
    results(1, 2) = Format(Timer - startTime, "0.000") & "秒"

    ' --- テスト2：配列に書き込んでから一括転送 ---
    ws.Cells.Clear
    startTime = Timer
    Dim arr() As Variant
    ReDim arr(1 To 5000, 1 To 1)
    For i = 1 To 5000
        arr(i, 1) = i
    Next i
    ws.Range("A1:A5000").Value = arr
    results(2, 1) = "配列→一括転送"
    results(2, 2) = Format(Timer - startTime, "0.000") & "秒"

    ' --- テスト3：AutoFillを使う ---
    ws.Cells.Clear
    startTime = Timer
    ws.Cells(1, 3).Value = 1
    ws.Cells(2, 3).Value = 2
    ws.Range("C1:C2").AutoFill Destination:=ws.Range("C1:C5000"), Type:=xlFillSeries
    results(3, 1) = "AutoFill（連番）"
    results(3, 2) = Format(Timer - startTime, "0.000") & "秒"

    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic

    ' 結果表示
    Dim msg As String
    msg = "=== ベンチマーク結果（5000行） ===" & vbCrLf & vbCrLf
    For i = 1 To 3
        msg = msg & results(i, 1) & ": " & results(i, 2) & vbCrLf
    Next i

    MsgBox msg, vbInformation
    Set ws = Nothing

End Sub

高速化設定の標準テンプレート

以下のテンプレートをすべてのマクロの基本形として使用することで、パフォーマンス問題の大半を予防できます。プロジェクトの標準モジュールにコピーして活用してください。

' ========================================
' 高速化・安定化の標準テンプレート（完全版）
' すべてのマクロの基本形として使用する
' ========================================
Option Explicit

' ---- 高速化設定ON ----
Private Sub SpeedUp()
    Application.ScreenUpdating = False
    Application.Calculation    = xlCalculationManual
    Application.EnableEvents   = False
    Application.DisplayAlerts  = False
    Application.Cursor         = xlWait   ' カーソルを砂時計に
End Sub

' ---- 高速化設定OFF（必ずペアで呼ぶ） ----
Private Sub SpeedDown()
    Application.ScreenUpdating = True
    Application.Calculation    = xlCalculationAutomatic
    Application.EnableEvents   = True
    Application.DisplayAlerts  = True
    Application.Cursor         = xlDefault
    Application.CutCopyMode    = False
    Application.StatusBar      = False
End Sub

' ========================================
' メインプロシージャのテンプレート
' ========================================
Sub MainTemplate()

    ' --- 変数宣言 ---
    Dim ws      As Worksheet
    Dim lastRow As Long
    Dim i       As Long
    Dim startTime As Single

    ' --- 開始処理 ---
    startTime = Timer
    SpeedUp

    On Error GoTo ErrorHandler

    ' ===== メイン処理 START =====

    Set ws      = ThisWorkbook.Sheets(1)
    lastRow     = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' データを配列に一括読み込み
    Dim srcData As Variant
    Dim outData As Variant

    srcData = ws.Range("A2:C" & lastRow).Value
    ReDim outData(1 To UBound(srcData, 1), 1 To 2)

    For i = 1 To UBound(srcData, 1)

        ' 進捗表示（1000行ごと）
        If i Mod 1000 = 0 Then
            Application.StatusBar = "処理中 " & i & "/" & UBound(srcData, 1) & "行"
            DoEvents
        End If

        ' 処理本体
        outData(i, 1) = srcData(i, 1) & srcData(i, 2)
        outData(i, 2) = IIf(IsNumeric(srcData(i, 3)), CDbl(srcData(i, 3)) * 1.1, 0)

    Next i

    ' 一括書き込み
    ws.Range("D2:E" & lastRow).Value = outData

    ' ===== メイン処理 END =====

    GoTo CleanUp

ErrorHandler:
    MsgBox "エラーが発生しました。" & vbCrLf & _
           "番号: " & Err.Number & vbCrLf & _
           "内容: " & Err.Description, vbCritical

CleanUp:
    ' --- 終了処理（エラー時も必ず実行） ---
    SpeedDown

    Dim elapsed As Single
    elapsed = Timer - startTime

    ' オブジェクト解放
    Set ws = Nothing

    MsgBox "処理完了（" & Format(elapsed, "0.00") & "秒）", vbInformation

End Sub

処理が重い・止まる原因チェックリスト

マクロが遅い・フリーズすると感じたとき、以下のリストを上から確認してください。

処理の前後に Application.ScreenUpdating = False/True を入れているか
処理の前後に Application.Calculation = xlCalculationManual/Automatic を入れているか
処理の前後に Application.EnableEvents = False/True を入れているか
エラー時も設定が 必ず元に戻る よう CleanUpラベルまたは On Error で処理しているか
ループ内でセルを1つずつ読み書きしていないか → 配列に一括読み込み・一括書き込みに変更する
ループの中で 毎回 End(xlUp).Row などのセルアクセスをしていないか（ループ外で1度だけ実行する）
コードに .Select や .Activate が多用されていないか（オブジェクト変数の直接操作に変更する）
文字列検索・置換を ループで1行ずつ処理していないか（Find/FindNext/Replace を使う）
長時間処理に DoEvents を適切な間隔（1000行に1回など）で呼んでいるか
ユーザーに処理の進捗を伝える ステータスバー表示を入れているか
大量データを分割して処理する場合、チャンク処理で配列をこまめに Erase してメモリを解放しているか
使い終わったオブジェクトを Set obj = Nothing で解放しているか
Do WhileループやFor Eachループに 終了条件が正しく設定されているか（無限ループになっていないか）
外部ファイル・アプリ待機ループに タイムアウト処理を入れているか
処理時間を Timer 関数で計測して改善効果を数値で確認しているか

まとめ

Excelマクロの処理が重くなる・止まる原因と対策を整理します。

画面更新・計算・イベントの停止：処理の前後に3行の設定を追加するだけで数倍〜数十倍の高速化が得られる。エラー時も設定が戻るようCleanUpラベルで管理する
配列による一括処理：ループ内でのセルの1つずつ読み書きを、配列への一括読み込み→処理→一括書き込みに変えることで最大100倍以上の高速化が可能。これがVBA高速化の最重要テクニック
ループの最適化：最終行取得などループ外に出せる処理をループ内に書かない。For EachをUnionやFind/Replaceで代替する
Select/Activateの排除：マクロ記録で生成されたSelectだらけのコードをオブジェクト変数の直接操作に書き換える
DoEventsとキャンセル処理：長時間処理でフリーズを防ぐため適切な間隔でDoEventsを呼ぶ。Escキーでの中断機能も合わせて実装する
進捗表示：ステータスバーで「今何行目を処理中か」を表示することで、ユーザーの誤った強制終了を防ぐ
メモリ管理：大量データはチャンク分割で処理し、配列を Erase・オブジェクトを Set Nothing でこまめに解放する
タイムアウト処理：無限ループを防ぐためDoループには最大回数・最大時間のガード処理を入れる

本記事の「高速化設定の標準テンプレート」を全マクロの基本形として採用するだけで、大半のパフォーマンス問題を予防できます。既存のマクロが遅い場合は、まず画面更新停止→次にセルアクセスの配列化という順で改善してください。

目次