Excel VBA 逆引き集 | 疑似並列

Excel VBA
スポンサーリンク

ねらい：VBAで「疑似並列」を作り、複数処理を同時進行の体感で回す

VBAはシングルスレッドですが、処理を小さなチャンクに分割して短時間で区切り、次回実行を予約（Application.OnTime）しながら進めると「並んで動いている」体感が得られます。重いループやI/O待ちを分割し、UI応答を保ちながら複数タスクを少しずつ進めるのがポイントです。テンプレートを「チャンク化・スケジューラ・タスクキュー・キャンセル・排他」の順に示し、初心者向けにかみ砕いて解説します。

重要ポイントの深掘り

  • 1チャンクの処理時間は100〜300msを目安に調整すると、体感応答と速度のバランスが良いです。
  • OnTimeで「次チャンクをすぐか数百ms後に」予約し、UIを解放するのが肝です。
  • DoEventsは多用せず、チャンク終端だけで十分。進捗表示は間引き（1〜5%刻み）で更新します。
  • 停止・再開・二重起動防止の枠を最初に用意しておくと、長時間でも落ちません。

疑似並列の骨格：チャンク実行とOnTimeスケジューラ

チャンク実行の最小テンプレート

' ModChunkTemplate.bas
Option Explicit

Private gCur As Long, gTotal As Long, gChunk As Long
Private gNext As Date, gStop As Boolean

Public Sub StartPseudoParallel(ByVal total As Long, ByVal chunk As Long, ByVal delayMs As Long)
    gTotal = total: gChunk = chunk: gCur = 0: gStop = False
    ScheduleNext delayMs
End Sub

Public Sub StopPseudoParallel()
    gStop = True
    Application.StatusBar = False
End Sub

Private Sub ScheduleNext(ByVal delayMs As Long)
    gNext = Now + (delayMs / 86400000#) ' ミリ秒→日
    Application.OnTime gNext, "'" & ThisWorkbook.Name & "'!TickPseudo", , True
End Sub

Public Sub TickPseudo()
    If gStop Then Exit Sub
    Dim endN As Long
    endN = WorksheetFunction.Min(gCur + gChunk, gTotal)

    Dim i As Long
    For i = gCur + 1 To endN
        ' ここに「小さい1件分の処理」を書く（例：配列1行の整形、行の集計など）
    Next

    gCur = endN
    Application.StatusBar = "進捗 " & Format(gCur / gTotal, "0%") & " (" & gCur & "/" & gTotal & ")"

    If gCur >= gTotal Then
        Application.StatusBar = "完了"
        Exit Sub
    End If

    ScheduleNext 200 ' 次チャンクを約200ms後に予約
End Sub
VB

重要ポイントの深掘り

  • TickPseudoは「短く終わる」ことが絶対条件。長すぎると疑似並列の効果が消え、UIが固まります。
  • 次回予約はブック修飾（’Book.xlsm’!Proc）で指定すると安定します。
  • delayMsを0にすれば即時連続、数百msならUI応答重視。現場の体感に合わせて調整しましょう。

タスクキュー：複数工程を交互に少しずつ進める

1タスクを分割して進めるクラス

' CTask.cls
Option Explicit

Private pName As String
Private pCur As Long
Private pTotal As Long
Private pDone As Boolean

Public Sub Init(ByVal name As String, ByVal total As Long)
    pName = name: pTotal = total: pCur = 0: pDone = False
End Sub

Public Property Get IsDone() As Boolean: IsDone = pDone: End Property
Public Property Get ProgressText() As String
    ProgressText = pName & " " & Format(pCur / pTotal, "0%") & " (" & pCur & "/" & pTotal & ")"
End Property

Public Sub RunChunk(ByVal chunkSize As Long)
    Dim toN As Long: toN = WorksheetFunction.Min(pCur + chunkSize, pTotal)
    Dim i As Long
    For i = pCur + 1 To toN
        ' ここに「1件分の処理」を書く（例：配列の要素処理）
    Next
    pCur = toN
    If pCur >= pTotal Then pDone = True
End Sub
VB

キューでラウンドロビン実行する

' CTaskQueue.cls
Option Explicit

Private tasks As Collection
Private idx As Long

Public Sub Init(): Set tasks = New Collection: idx = 0: End Sub
Public Sub AddTask(ByVal t As CTask): tasks.Add t: End Sub

Public Sub RunNext(ByVal chunkSize As Long)
    If tasks.Count = 0 Then Exit Sub
    If idx = 0 Then idx = 1
    Dim t As CTask: Set t = tasks(idx)
    If Not t.IsDone Then t.RunChunk chunkSize
    idx = IIf(idx = tasks.Count, 1, idx + 1)
End Sub

Public Function AllDone() As Boolean
    Dim t As CTask, i As Long
    For i = 1 To tasks.Count
        Set t = tasks(i)
        If Not t.IsDone Then Exit Function
    Next
    AllDone = True
End Function

Public Function Summary() As String
    Dim s As String, i As Long, t As CTask
    For i = 1 To tasks.Count
        Set t = tasks(i)
        s = s & IIf(Len(s) > 0, " | ", "") & t.ProgressText
    Next
    Summary = s
End Function
VB

スケジューラでキューを回す

' ModMultiScheduler.bas
Option Explicit
Private gQueue As CTaskQueue
Private gNext As Date
Private gStop As Boolean
Private gChunk As Long

Public Sub StartQueue(ByVal chunkSize As Long, ByVal delayMs As Long)
    gStop = False: gChunk = chunkSize
    Set gQueue = New CTaskQueue: gQueue.Init

    Dim t1 As New CTask: t1.Init "Import", 12000
    Dim t2 As New CTask: t2.Init "Normalize", 8000
    Dim t3 As New CTask: t3.Init "Aggregate", 5000

    gQueue.AddTask t1: gQueue.AddTask t2: gQueue.AddTask t3
    ScheduleNext delayMs
End Sub

Public Sub StopQueue(): gStop = True: Application.StatusBar = False: End Sub

Private Sub ScheduleNext(ByVal delayMs As Long)
    gNext = Now + (delayMs / 86400000#)
    Application.OnTime gNext, "'" & ThisWorkbook.Name & "'!TickQueue", , True
End Sub

Public Sub TickQueue()
    If gStop Then Exit Sub

    gQueue.RunNext gChunk
    Application.StatusBar = gQueue.Summary

    If gQueue.AllDone Then
        Application.StatusBar = "完了"
        Exit Sub
    End If

    ScheduleNext 200
End Sub
VB

重要ポイントの深掘り

  • ラウンドロビンで「公平に少しずつ」進めると、どの工程も停滞しません。
  • 進捗はStatusBarにまとめて表示すると、全体の見通しが良くなります。
  • 1件分の処理は「なるべく一定時間」に近づけておくと、体感の滑らかさが上がります。

実データ向けのチャンク設計：配列I/Oで確実に速くする

巨大範囲を分割して処理する

' ModChunkArray.bas
Option Explicit

Public Sub ChunkProcessRange(ByVal wsName As String, ByVal firstRow As Long, ByVal lastRow As Long, ByVal chunk As Long)
    Dim ws As Worksheet: Set ws = Worksheets(wsName)
    Dim startRow As Long: startRow = firstRow
    Do While startRow <= lastRow
        Dim endRow As Long: endRow = WorksheetFunction.Min(startRow + chunk - 1, lastRow)
        Dim arr As Variant
        arr = ws.Range(ws.Cells(startRow, "A"), ws.Cells(endRow, "F")).Value

        Dim i As Long
        For i = 1 To UBound(arr, 1)
            ' ここで1行分の処理（例：Trim、数値変換、合計など）
        Next

        ws.Range(ws.Cells(startRow, "A"), ws.Cells(endRow, "F")).Value = arr
        startRow = endRow + 1
    Loop
End Sub
VB

重要ポイントの深掘り

  • セルを1件ずつ触ると固まります。必ず配列へ一括で読み、配列内で処理し、一括で書き戻します。
  • チャンク終端でのみUI更新（StatusBar）を入れ、DoEventsは使わずOnTimeでUI応答を確保します。

非同期I/Oの併用：ネット通信はイベントで受け取り、計算はキューで進める

XMLHTTPを非同期で投げて待たない

' CHttpGet.cls
Option Explicit

Public WithEvents X As Object
Private pDone As Boolean, pOk As Boolean, pText As String

Public Sub Start(ByVal url As String)
    Set X = CreateObject("MSXML2.XMLHTTP")
    X.Open "GET", url, True
    X.Send
End Sub

Private Sub X_onreadystatechange()
    If X.readyState = 4 Then
        pOk = (X.Status = 200)
        If pOk Then pText = CStr(X.responseText)
        pDone = True
    End If
End Sub

Public Property Get IsDone() As Boolean: IsDone = pDone: End Property
Public Property Get Ok() As Boolean: Ok = pOk: End Property
Public Property Get Text() As String: Text = pText: End Property
VB

重要ポイントの深掘り

  • 通信はイベントで完了通知を受けるので、メインの疑似並列タスクを止めません。
  • Tick側（キュー）でIsDoneを確認し、結果を取り込むと「計算と通信が並ぶ」体感が生まれます。
  • 失敗時は再試行ポリシー（最大回数、待機）をキューに組み込みます。

安全装備：排他ロック・キャンセル・共通枠で必ず復帰

二重起動を防ぐロック

' ModLock.bas
Option Explicit

Public Function TryLock() As Boolean
    On Error Resume Next
    ThisWorkbook.Names("nm_Lock").RefersToRange.Value = Environ$("UserName") & "@" & Format(Now, "yyyy-mm-dd HH:NN:SS")
    TryLock = (Err.Number = 0)
    Err.Clear
    On Error GoTo 0
End Function

Public Sub Unlock()
    On Error Resume Next
    ThisWorkbook.Names("nm_Lock").RefersToRange.Value = ""
    On Error GoTo 0
End Sub
VB

開始・終了の共通枠

' ModApp.bas
Option Explicit
Public Sub AppEnter(Optional ByVal status As String = "")
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    If Len(status) > 0 Then Application.StatusBar = status
End Sub
Public Sub AppLeave()
    Application.StatusBar = False
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
VB

重要ポイントの深掘り

  • ロックが取れないときは入口で即停止し、「走っている」ことを通知。事故の8割は二重起動です。
  • キャンセルはフラグを立て、次Tickで抜ける形が安全。途中でも必ずStatusBarを戻す設計にします。
  • 例外時でもAppLeaveとUnlockが到達するよう、Finally相当の構造を徹底します。

例題の通し方と調整ポイント

通し手順

  • StartQueue(chunkSize:=500, delayMs:=200) を実行し、Import→Normalize→Aggregateが交互に進むこと、StatusBarに進捗が並ぶこと、UI操作が可能なまま進むことを確認します。
  • StopQueueで安全に停止できるか、次Tickで抜けてStatusBarが消えるかを確認します。
  • chunkSizeを300〜1000、delayMsを0〜300で試し、体感応答と総時間のバランスを掴みます。

調整ポイント

  • 1件分の処理が重い（>50ms）場合は更に小さく分割するか、前処理で軽量化します。
  • I/O（保存・読込）はチャンク外の“別タスク”に分離し、失敗時リトライを組みます。
  • 進捗は1〜5%刻みで間引き。毎回更新は遅くなるだけです。

まとめ：分割・予約・持ち回りで「並んで進む」体感を作る

  • 仕事をチャンクに分割し、OnTimeで段階実行。
  • タスクキューで複数工程を公平に持ち回り、UIを固めない。
  • 非同期通信や外部プロセスを組み合わせれば、実質的な並行も可能。
  • 排他・キャンセル・共通枠を標準装備して、長時間でも落ちない運用に。

スポンサーリンク
タイトルとURLをコピーしました