ここ参照
Option Explicit
'親部分
Sub Main()
Const MAX_PROCESS = 10
Dim Apps As Collection: Set Apps = New Collection
Dim i As Long
'下準備
Dim App As Excel.Application
Dim Wb As Workbook
For i = 1 To MAX_PROCESS
'別インスタンスのExcelを起動
Set App = New Application
Apps.Add App
'自分自身を別のインスタンスでも読み取り専用で開かせる
Set Wb = App.Workbooks.Open(ThisWorkbook.FullName, _
UpdateLinks:=False, _
ReadOnly:=True)
'子プロセスに司令を出す。
'※この時呼ばれるプロシージャにはOnTimeのみを
'記述し直ちに応答を返さなければならない。
App.Run "'" & Wb.Name & "'!ExecSubMacro", i
DoEvents
Next
Set App = Nothing
Set Wb = Nothing
'子プロセスの終了待ち : とりあえずWorkbookの数で判断する。
For i = 1 To Apps.Count
ContinueFor:
If Apps(i).Workbooks.Count > 0 Then
Application.Wait [Now() + "00:00:00.2"]
DoEvents
'Debug.Print "Not Closed : "; i
GoTo ContinueFor
End If
Next
'子Excelのインスタンスの破棄
'これをサボるとEXCEL.EXEがゾンビ化するかもしれない。
On Error Resume Next
For i = 1 To Apps.Count
Apps(1).Quit
Apps.Remove 1
Next
On Error GoTo 0
MsgBox "完了！"
End Sub
'SubMacroを別のスレッドで実行させる。
'本プロシージャは呼び出し元に直ちに制御を返さなければならない。
Sub ExecSubMacro(n As Long)
'OnTimeはThisWorkbookプロセスのスレッドでの呼び出しになる。
Application.OnTime [Now() + "00:00:00.2"], "'SubMacro """ & n & """'"
End Sub
'時間のかかる処理
Sub SubMacro(n As Long)
'適当に重い処理をする。：WaitはCPUをバカ食いするので採用
'本当に実行されたことを確認するため、同フォルダにテキストファイルを出力する。
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim ts As TextStream: Set ts = fso.CreateTextFile(ThisWorkbook.Path & "\" & n & ".txt")
Dim i As Long
For i = 1 To 10
ts.WriteLine Format(Now(), "yyyy/mm/dd hh:mm:ss") & " " & i
Application.Wait [Now() + "00:00:01"]
Next
ts.Close
Set ts = Nothing
'ブックを閉じることが処理終了の合図とする。
Application.DisplayAlerts = False
ThisWorkbook.Close False
'親VBAが捕まえているため、このQuitは無視される気配
Application.Quit
End Sub
