マルチプロセス


はじめに

ループ回数の多い処理を以下の3通りの方法で処理を行い、処理時間を調べます。
@セル単位書込み方式
A2次元配列範囲書込み方式
Bマルチプロセス+2次元配列範囲書込み方式

今回の例題処理は、10万行×100列の範囲のセルそれぞれにセルのアドレスをセットします。

@セル単位書込み方式

高速化を意識しない通常の処理方式です。

Option Explicit

Sub Test1()

  Dim R As Long
  Dim C As Long
  Dim WB As Workbook
  Dim WS As Worksheet
  
  Dim Bef As Date
  Dim Aft As Date
  
  
  Bef = Time
  
  Application.WindowState = xlMinimized
  Application.ScreenUpdating = False
  
  Set WB = ThisWorkbook
  Set WS = WB.Worksheets(1)
  
  For R = 1 To 100000
     For C = 1 To 100
        WS.Cells(R, C).Value = WS.Cells(R, C).Address
     Next C
  Next R

  Set WS = Nothing
  Set WB = Nothing

  Application.ScreenUpdating = True
  Application.WindowState = xlNormal
  
  Aft = Time
  MsgBox Minute(Aft - Bef) & "'" & Second(Aft - Bef)

End Sub

処理時間は2分46秒でした。

A2次元配列範囲書込み方式

高速化を意識して、セルへのセットをセルごとではなく、全体の範囲をまとめて1回で行いました。

Option Explicit
Option Base 1

Sub Test2()

  Dim R As Long
  Dim C As Long
  Dim WB As Workbook
  Dim WS As Worksheet
  Dim Arr(100000, 100) As String
  
  Dim Bef As Date
  Dim Aft As Date
  
  
  Bef = Time
  
  Application.WindowState = xlMinimized
  Application.ScreenUpdating = False
  
  Set WB = ThisWorkbook
  Set WS = WB.Worksheets(1)
  
  For R = 1 To 100000
     For C = 1 To 100
        Arr(R, C) = WS.Cells(R, C).Address
     Next C
  Next R

  WS.Range(WS.Cells(1, 1), WS.Cells(100000, 100)).Value = Arr
  
  Set WS = Nothing
  Set WB = Nothing

  Application.ScreenUpdating = True
  Application.WindowState = xlNormal
  
  Aft = Time
  MsgBox Minute(Aft - Bef) & "'" & Second(Aft - Bef)

End Sub

処理時間は36秒でした。
高速化の効果が大きいです。
今回は大丈夫でしたが、あまりに大きいセル範囲を一度に扱うと(10万行×100列も十分大きいですが)、
エラーが起こって、処理できない可能性があります。

Bマルチプロセス+2次元配列範囲書込み方式

今回の本題のマルチプロセスです。
Excelを複数起動して(今回は最初に開いているExcelに加えて5つのExcelを開きます)、
それぞれのExcelで処理を分担します。
@、Aと違って処理が複雑なので、処理の流れを説明します。

本体(親)
(1)以下を5回ループ。
 ・Excelを起動して自分自身のExcelファイルを開くVBスクリプトを作成。
 ・Windows APIのShellExecute関数で上記で作成したVBスクリプトを実行。
(2)起動した5つの別プロセスExcel処理が完了するまで待つ。

別プロセス(子)
(1)ファイル起動に応じて、5分割した実処理を実行。
(2)終了した目印のファイルを作成。
(3)自分が最後の場合、終了目印ファイルをすべて削除。
(4)Excelを終了。

ThisWorkbookのコード

Option Explicit
Const MaxP = 5

Private Sub Workbook_Open()
  
  Dim APP1st As Object
  Dim P As Long
  Dim VBSPath As String

  If ThisWorkbook.ReadOnly = True Then
     Set APP1st = GetObject(, "Excel.Application")
     If Application Is APP1st Then
     Else
        For P = 1 To MaxP
           VBSPath = ThisWorkbook.Path & "\" & P & ".vbs"
           If Dir(VBSPath) <> "" Then
              On Error Resume Next
              Kill VBSPath
              On Error GoTo 0
              Call Test3S(P)
              ThisWorkbook.Saved = True
              Application.Quit
           End If
        Next P
     End If
     Set APP1st = Nothing
  End If

End Sub

標準モジュールのコード

Option Explicit
Option Base 1

#If Win64 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
   ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   ByVal lpParameters As String, ByVal lpDirectory As String, _
   ByVal nShowCmd As Long) As Long
#Else
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
   ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   ByVal lpParameters As String, ByVal lpDirectory As String, _
   ByVal nShowCmd As Long) As Long
#End If
  
Const MaxP = 5

Sub Test3()

  Dim P As Long
  Dim VBSPath As String
  Dim LineText As String
  Dim Ret As Long

  Dim Bef As Date
  Dim Aft As Date


  Bef = Time
  
  Application.WindowState = xlMinimized
  Application.ScreenUpdating = False

  For P = 1 To MaxP
     VBSPath = ThisWorkbook.Path & "\" & P & ".vbs"
     
     Open VBSPath For Output As #1

     LineText = "Option Explicit"
     Print #1, LineText
     LineText = "Dim strPath"
     Print #1, LineText
     LineText = "Dim xlApp"
     Print #1, LineText
     LineText = "With WScript"
     Print #1, LineText
     LineText = "strPath = Replace(.ScriptFullName, .ScriptName, " & Chr$(34) & Chr$(34) & _
                ") & " & Chr$(34) & ThisWorkbook.Name & Chr$(34)
     Print #1, LineText
     LineText = "End With"
     Print #1, LineText
     LineText = "Set xlApp = CreateObject(" & Chr$(34) & "Excel.Application" & Chr$(34) & ")"
     Print #1, LineText
     LineText = "xlApp.Visible = True"
     Print #1, LineText
     LineText = "xlApp.Visible = False"
     Print #1, LineText
     LineText = "xlApp.Workbooks.Open strPath, False, True"
     Print #1, LineText
     LineText = "Set xlApp = Nothing"
     Print #1, LineText
  
     Close #1
  
     Ret = ShellExecute(0, "open", VBSPath, vbNull, vbNull, 1)
     If Ret < 32 Then
        On Error Resume Next
        Kill VBSPath
        On Error GoTo 0
        VBSPath = ThisWorkbook.Path & "\0.vbs"
        Open VBSPath For Output As #1
        Close #1
        Exit For
     End If
  Next P

  VBSPath = ThisWorkbook.Path & "\0.vbs"
  Open VBSPath For Output As #1
  Close #1
  Do While Dir(VBSPath) <> ""
     DoEvents
  Loop

  Application.ScreenUpdating = True
  Application.WindowState = xlNormal
  
  Aft = Time
  MsgBox Minute(Aft - Bef) & "'" & Second(Aft - Bef)

End Sub

Sub Test3S(ByVal P As Long)

  Dim R As Long
  Dim C As Long
  Dim APP1st As Object
  Dim WB As Workbook
  Dim WS As Worksheet
  Dim SR As Long
  Dim ER As Long
  Dim Arr(20000, 100) As String
  
  Dim VBSPath As String
  Dim FlgLast As Boolean
  Dim I As Long


  Application.WindowState = xlMinimized
  Application.ScreenUpdating = False
    
  Set WB = ThisWorkbook
  Set WS = WB.Worksheets(1)
  
  SR = 20000 * (P - 1) + 1
  ER = 20000 * P
  
  For R = SR To ER
     For C = 1 To 100
        Arr(R - SR + 1, C) = WS.Cells(R, C).Address
     Next C
  Next R

  Set APP1st = GetObject(, "Excel.Application")
  Set WB = APP1st.Workbooks(ThisWorkbook.Name)
  Set WS = WB.Worksheets(1)
  
  WS.Range(WS.Cells(SR, 1), WS.Cells(ER, 100)).Value = Arr

  Set WS = Nothing
  Set WB = Nothing
  Set APP1st = Nothing

  VBSPath = ThisWorkbook.Path & "\" & P & "E.vbs"
  Open VBSPath For Output As #1
  Close #1
  
  FlgLast = True
  For I = 1 To MaxP
     VBSPath = ThisWorkbook.Path & "\" & I & "E.vbs"
     If Dir(VBSPath) = "" Then
        FlgLast = False
        Exit For
     End If
  Next I
  
  If FlgLast = True Then
     For I = 1 To MaxP
        VBSPath = ThisWorkbook.Path & "\" & I & "E.vbs"
        If Dir(VBSPath) <> "" Then
           On Error Resume Next
           Kill (VBSPath)
           On Error GoTo 0
        End If
     Next I
     VBSPath = ThisWorkbook.Path & "\0.vbs"
     On Error Resume Next
     Kill (VBSPath)
     On Error GoTo 0
  End If

End Sub

処理時間は24秒でした。
少し速くなりました。
コードが非常に複雑になる割には高速化の効果はそれほどないように見受けられます。
例題があまりよくなかったのかもしれません。
正規表現検索のアドインでは、Grepやパスワード解析でこの方式を利用しています。

処理が難解になるためあまりお勧めはしません。
また、エラー時などに別プロセスのExcelが残ったままになることがあるという問題もあります。
高速化の最後の手段です。


Excel VBA講座に戻ります

トップに戻ります


お探しの情報は見つかりましたか?
まだの方はこちらをどうぞ。
Google

PageTop