EXCEL VBA MULTITHREADING

This is another post I have started beeing inspired by posts on AnalystCave blog, and wanted to reach further from where he left it.

There are some starting posts with info that worth to take a look before getting hands on dough:

What I’m trying to achieve here is to develop a macro that can select a procedure on the same workbook (or in another one), and harness the power of multithreading converting the procedure in a VBScript thread.

So let’s get started.

The running code

Following are my final design (by 15/01/2019) of the multithreading topic. There are some code uncommented, not in use, but is kept here if it’s needed in the future.

' Author: Tomasz Kacprowicz
' Modifications: Enrique Luengo

Option Explicit

Dim startD As Date
Dim endD As Date

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

'Private Declare Function CreateThread Lib "kernel32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
'Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
'.... temporally invented (search in Google for full declaration)
'Private Declare Function GetCurrentThread Lib "kernel32" ()
'Private Declare Function GetExitCodeThread Lib "kernel32" ()
'Private Declare Function ExitThread Lib "kernel32" ()
'Private Declare Function TerminateThread Lib "kernel32" ()
'
'Sub a_test()
'    Dim hndThread As Long
'    Dim lgCounter As Long
'
'    On Error Resume Next
'
'    For lgCounter = 1 To 100000
'        ' Free threaded approach
'        hndThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf AsyncThread, 0&, ByVal 0&, 0&)
'        If hndThread = 0 Then ' (error)
'            Exit Sub
'        End If
'
'        ' We don't need the thread handle
'        CloseHandle hndThread
'    Next lgCounter
'
'    MsgBox "Done"
'End Sub
'
'Function AsyncThread()
'    On Error Resume Next
'
'    ' Do Stuff
'
'    ' Clean up Thread
'    AsyncThread = True
'    Dim lpExitCode
'    GetExitCodeThread GetCurrentThread, lpExitCode
''    ExitThread lpExitCode ' Crashes Excel
'    TerminateThread GetCurrentThread, lpExitCode
'End Function

Private Sub SaveRangeToMaster(ByVal masterWorkbookName As String, _
                              ByRef r As Excel.Range)
'Save data to the master file
    Dim oXLmain As Excel.Application 'Object
    
    Set oXLmain = GetObject(, "Excel.Application")
    oXLmain.Workbooks(masterWorkbookName) _
           .Sheets(r.Worksheet.Name) _
           .Range(r.address) _
           .Value2 = r.Value2
    Set oXLmain = Nothing
End Sub

Private Sub SetRangeToMaster(ByVal masterWorkbookName As String, _
                             ByVal sheetName As String, _
                             ByVal rangeAddress As String, _
                             ByVal val As Variant)
'Set data to the master file
    Dim oXLmain As Excel.Application 'Object
    
    Set oXLmain = GetObject(, "Excel.Application")
    oXLmain.Workbooks(masterWorkbookName) _
           .Sheets(sheetName) _
           .Range(rangeAddress) _
           .Value = val
    Set oXLmain = Nothing
End Sub

Public Sub TestMultithreading()
    Dim par As clsParallel
    
    Set par = New clsParallel
    par.SetThreads 2
    par.SetWorkBook ActiveWorkbook 'ThisWorkbook 'Application.Workbooks.Open(...)
    
    startD = Timer
    Call par.Parallel("RunTest", 1, 200000000, "A1") '... up to 30 arguments to run the macro
    endD = Timer
    
    MsgBox endD - startD
    Set par = Nothing
End Sub

Private Sub RunTest(ByVal workbookName As String, _
                    ByVal fromArg As Long, _
                    ByVal toArg As Long, _
                    Optional ByVal address As String)
    Dim r As Excel.Range
    Dim i As Long
    Dim x As Double
    
    For i = fromArg To toArg
        x = fromArg / toArg
    Next i
    
    Set r = Range(address)
    r.Value = toArg
    Call SaveRangeToMaster(workbookName, r)
End Sub

This code relies on the Tomasz Kacprowicz’s class Parallel, that I have modified to perform better (I think), and to be more understandable in the steps it executes. Paste this code in a Class, and call it clsParallel.

' Author: Tomasz Kacprowicz
' Modifications: Enrique Luengo
Option Explicit

Private cThreads As Long
Private parallelKey As String
Private Workbook As Excel.Workbook

Private Sub class_initialize()
    ' set 4 cores processor as default (each core will handle 1 thread at max performance)
    cThreads = 4
    
    Call VBA.Randomize
    parallelKey = VBA.Hex(VBA.CLng(VBA.Rnd() * 1000000)) ' "Unique" key for tracking
End Sub

Private Sub Class_Terminate()
    DropSemaphores
End Sub

Public Sub SetThreads(ByVal threads As Long)
    If threads > 0 Then cThreads = threads
End Sub

Public Sub SetWorkBook(ByVal oWbk As Excel.Workbook)
    Set Workbook = oWbk
End Sub

'Public Function GetThreads() As Long
'    GetThreads = cThreads
'End Function

'Public Function GetThread(ByVal strFile As String) As Long
'    GetThread = CLng(Mid(strFile, _
'                         InStr(strFile, "_") + 1, _
'                         InStr(strFile, ".") - InStr(strFile, "_") - 1))
'End Function

Private Sub CreateSemaphores()
    Dim thread As Long
    
    For thread = 1 To cThreads
        Call Workbook.Names.Add(Name:="_" & parallelKey & "_" & thread, RefersTo:="=0", Visible:=True)
    Next thread
End Sub

Private Sub DropSemaphores()
    Dim thread As Long
    
    On Error Resume Next
    For thread = 1 To cThreads
        Call Workbook.Names("_" & parallelKey & "_" & thread).Delete
    Next thread
    On Error GoTo 0
End Sub

Private Function CountSemaphores() As Long
    Dim thread As Long
    Dim c As Long
    
    c = 0
    For thread = 1 To cThreads
        If VBA.CLng(VBA.Replace(Expression:=Workbook.Names("_" & parallelKey & "_" & thread).Value2, Find:="=", Replace:="")) > 0 Then
            c = c + 1
        End If
    Next thread
    CountSemaphores = c
End Function

Private Function CountActive() As Long
    Dim thread As Long
    Dim c As Long
    
    c = 0
    For thread = 1 To cThreads
        If VBA.CLng(Workbook.Names("_" & parallelKey & "_" & thread).Value2 = 1) > 0 Then
            c = c + 1
        End If
    Next thread
    CountActive = c
End Function

Private Sub NewThread(ByVal strVBScript As String, _
                      ByVal thread As Long, _
                      ByVal args As String)
    Dim s As String
    Dim sFileName As String
    Dim oWSh As Object
    
    'Save a copy of the Excel workbook
    Dim threadFileName As String
    threadFileName = Workbook.Path & "\" & parallelKey & "_" & thread & ".xls"
    Call ActiveWorkbook.SaveCopyAs(threadFileName)
    
    'Save the VBscript to file
    Dim iFileVBS As Integer
    iFileVBS = VBA.FreeFile()
    sFileName = Workbook.Path & "\" & parallelKey & "_" & thread & ".vbs"
    Open sFileName For Output As #iFileVBS
    Print #iFileVBS, strVBScript
    Close #iFileVBS
    
    'Execute the VBscript file asynchronously
    Set oWSh = VBA.CreateObject("WScript.Shell")
    oWSh.Run """" & sFileName & """"
    Set oWSh = Nothing
End Sub

Public Function IsTheadRunning(ByVal thread As Long) As Boolean
    'If VBA.Dir(Workbook.Path & "\" & parallelKey & "_" & thread & ".vbs") Then
    '    IsTheadRunning = True
    'Else
    '    IsTheadRunning = False
    'End If
    IsTheadRunning = VBA.CBool(Workbook.Names("_" & parallelKey & "_" & thread).Value2)
End Function

Private Sub ThreadsJoin()
    Dim thread As Long

    Do Until False
        DoEvents
        If CountSemaphores >= cThreads Then
            Sleep 100
            'Kill Workbook.Path & "\" & parallelKey & "_" & "*.vbs"
            Kill Workbook.Path & "\" & parallelKey & "_" & "*.xls"
            DropSemaphores
            Exit Sub
        End If
        Sleep 10
    Loop
End Sub

Public Function Parallel(ByVal macroName As String, _
                         ByVal seqFrom As Long, _
                         ByVal seqTo As Long, _
                         Optional ByVal arg1 As Variant, Optional ByVal arg2 As Variant, _
                         Optional ByVal arg3 As Variant, Optional ByVal arg4 As Variant, _
                         Optional ByVal arg5 As Variant, Optional ByVal arg6 As Variant, _
                         Optional ByVal arg7 As Variant, Optional ByVal arg8 As Variant, _
                         Optional ByVal arg9 As Variant, Optional ByVal arg10 As Variant, _
                         Optional ByVal arg11 As Variant, Optional ByVal arg12 As Variant, _
                         Optional ByVal arg13 As Variant, Optional ByVal arg14 As Variant, _
                         Optional ByVal arg15 As Variant, Optional ByVal arg16 As Variant, _
                         Optional ByVal arg17 As Variant, Optional ByVal arg18 As Variant, _
                         Optional ByVal arg19 As Variant, Optional ByVal arg20 As Variant, _
                         Optional ByVal arg21 As Variant, Optional ByVal arg22 As Variant, _
                         Optional ByVal arg23 As Variant, Optional ByVal arg24 As Variant, _
                         Optional ByVal arg25 As Variant, Optional ByVal arg26 As Variant, _
                         Optional ByVal arg27 As Variant, Optional ByVal arg28 As Variant, _
                         Optional ByVal arg29 As Variant, Optional ByVal arg30 As Variant) As Boolean
    Dim thread As Long
    Dim Module As Double
    Dim args As String
    Dim s As String
    Dim strVBScriptThread As String
    
    CreateSemaphores ' names in ActiveWorkbook that will hold the thread semaphores
    
    'Create Thread template
    s = s & "' 1. Create new parallel thread (new Excel App): "
    s = s & "Dim oXLparallelApp: " ' Object that handles the parallel "{thread?}"
    s = s & ": "
    s = s & "Set oXLparallelApp = CreateObject(""Excel.Application""): "
    s = s & "With oXLparallelApp: "
    s = s & "  .Application.Visible = False: "
    s = s & "  .Workbooks.Open(""" & "{threadFileName?}" & """): "
    s = s & ": "
    s = s & "  ' 2. run the parallelized procedure: "
    s = s & "  .Application.Run """ & parallelKey & "_" & "{thread?}" & ".xls!" & _
            macroName & """ , """ & _
            Workbook.Name & """," & _
            "{subSeqFrom?}" & "," & _
            "{subSeqTo?}" & ": "
'!!!!!!!!!!!!!!!!!
' args & ":"  ' we can feed up to 30 args
' To run a specific macro: "myBook.xlsm!myModule.myMacro"
'!!!!!!!!!!!!!!!!!
    s = s & "  .ActiveWorkbook.Close True: "
    s = s & "  .Application.Quit: "
    s = s & "End With: "
    s = s & "Set oXLparallelApp = Nothing: "
    
    's = s & "' 3. Actualize thread counter in main Workbook: "
    's = s & "On Error Resume Next: "
    's = s & "Dim oXLmainApp: " ' Object that handles the main app
    's = s & ": "
    's = s & "Set oXLmainApp = GetObject(, ""Excel.Application""): "
    
    's = s & "If Err.Number <> 0 Then: "
    's = s & "  If Err.Number = 429 Then 'No current instance of Excel start up Excel: "
    's = s & "    Err.Clear: "
    's = s & "    'WScript.Quit: "
    's = s & "    'If oXLmainApp <> ""Microsoft Excel"" Then: "
    's = s & "    '  Set oXLmainApp = CreateObject(""Excel.Application""): "
    's = s & "    'End If: "
    's = s & "  End If: "
    's = s & "End If: "
    's = s & "'If TypeName(oXLmainApp) = ""Empty"" Then: "
    's = s & "'  MsgBox ""Excel NOT Running"", vbInformation, ""Excel Status"": "
    's = s & "'  'WScript.Quit: "
    's = s & "'End If: "
    's = s & "On Error Resume Next: "
    's = s & ": "
    's = s & "'If oXLmainApp.Workbooks.Count > 0 Then: "
    's = s & "  'For Each oXLWbk In oXLmainApp.Workbooks: "
    's = s & "  On Error Resume Next: "
    's = s & "  Set oXLWbk = oXLApp.WorkBooks(""" & Workbook.Name & """): "
    's = s & "  oXLWbk.Activate: "
    's = s & "  If Err <> 0 Then: "
    's = s & "   ' unable to activate, so workbook was not open -> open it now: "
    's = s & "    Dim fullPath: fullPath = InputBox(""Give full path and name for workbook"", , oXLApp.ActiveWorkbook.Name): "
    's = s & "    If Not vbYes = MsgBox(""Open workbook ["" & fullPath & ""]?"", vbYesNo) Then 'WScript.Quit: "
    's = s & "    'Set oXLWbk = oXLmainApp.Workbooks.Open(fullPath, 0, True): "
    's = s & "    Set oXLWbk = oXLmainApp.ActiveWorkbook: "
    's = s & "  End If: "
    's = s & "  Err.Clear: "
    's = s & "  On Error GoTo 0: "
    's = s & "  'Next: "
    's = s & "'End If: "
    
    's = s & "With oXLmainApp: "
    's = s & "  .Workbooks(""" & Workbook.Name & """)" & _
            ".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2 = 1: " ' while running...
    's = s & ": "
    's = s & "  Do Until CLng(Replace(.Workbooks(""" & Workbook.Name & """)" & _
            ".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2,""="","""")) = 1: "
    's = s & "    If Err.Number <> 0 Then Exit Do: "
    's = s & "    WScript.Sleep(100): "
    's = s & "    .Workbooks(""" & Workbook.Name & """)" & _
            ".Names(""_" & parallelKey & "_" & "{thread?}" & """).Value2 = 1: "
    's = s & "  Loop: "
    's = s & "End With: "
    's = s & "Set oXLmainApp = Nothing: "
    's = s & ": "
    's = s & "'On Error GoTo 0: "
    
    ' Autokill...
    s = s & "Kill " & Workbook.Path & "\" & parallelKey & "_" & "{thread?}" & "*.vbs: "
    s = VBA.Replace(s, ": ", vbCrLf)
    
    'If argX Like "Sheet:=*" Then
    '    argX = VBA.Mid$(argX, VBA.InStr(1, argX, ":=") + 2)
    'ElseIf argX Like "Address:=*" Then
    '    argX = VBA.Mid$(argX, VBA.InStr(1, argX, ":=") + 2)
    'End If
    
    args = args & ", " & GetArg(arg1)
    args = args & ", " & GetArg(arg2)
    args = args & ", " & GetArg(arg3)
    args = args & ", " & GetArg(arg4)
    args = args & ", " & GetArg(arg5)
    args = args & ", " & GetArg(arg6)
    args = args & ", " & GetArg(arg7)
    args = args & ", " & GetArg(arg8)
    args = args & ", " & GetArg(arg9)
    args = args & ", " & GetArg(arg10)
    args = args & ", " & GetArg(arg11)
    args = args & ", " & GetArg(arg12)
    args = args & ", " & GetArg(arg13)
    args = args & ", " & GetArg(arg14)
    args = args & ", " & GetArg(arg15)
    args = args & ", " & GetArg(arg16)
    args = args & ", " & GetArg(arg17)
    args = args & ", " & GetArg(arg18)
    args = args & ", " & GetArg(arg19)
    args = args & ", " & GetArg(arg20)
    args = args & ", " & GetArg(arg21)
    args = args & ", " & GetArg(arg22)
    args = args & ", " & GetArg(arg23)
    args = args & ", " & GetArg(arg24)
    args = args & ", " & GetArg(arg25)
    args = args & ", " & GetArg(arg26)
    args = args & ", " & GetArg(arg27)
    args = args & ", " & GetArg(arg28)
    args = args & ", " & GetArg(arg29)
    args = args & ", " & GetArg(arg30)
Stop
    'Create threads
    Module = CDbl(seqTo - seqFrom) / cThreads
    For thread = 1 To cThreads
        strVBScriptThread = VBA.Replace(s, "{threadFileName?}", Workbook.Path & "\" & parallelKey & "_" & thread & ".xls")
        strVBScriptThread = VBA.Replace(s, "{subSeqFrom?}", seqFrom + CLng((thread - 1) * Module))
        strVBScriptThread = VBA.Replace(s, "{subSeqTo?}", seqFrom + CLng(thread * Module))
        strVBScriptThread = VBA.Replace(s, "{thread?}", thread)
        Call NewThread(strVBScriptThread, thread, args)
    Next thread
    
    'Join threads returns
    ThreadsJoin
End Function

Private Function GetArg(ByVal val As Variant) As String
    If VarType(val) = vbString Then
        GetArg = """" & val & """"
    Else
        GetArg = "" & val
    End If
End Function

The modifications

We must explore which are the paths we could explore to make progress in this multithreading topic.

Isolating the main Office objects. Dealing with multithreading in independent Shell instances may require macro to connect to Office core application (Excel.Application, Word.Application,…). But, as they are external, they don’t know about the Office related applications. We need to access this elements via late binding, through object containers. We cannot recall on Excel., Word.,… whatever, and then create with the reserved word New. They have to be specifically redeclared as “Object” (see note) and then created via the CreateObject method. Note here, as VBScript is not tiped defined, they are all variants/objects, you just do not need to specify the As… type.

Here is a sample on how to load a swarm of bot agents (initially it was used to scrap a website… now is on it’s way to do something else, but the core is kept). Maybe, on of the main points to note here is that you do not need to stringify the VBA code, if you just can open a new Excel instance and call it through the Application.Run command.

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private oIE As Object  'As SHDocVw.InternetExplorer ' Microsoft Internet Controls must be referenced in Tools > References.
Private oXML As Object 'As MSXML2.XMLHTTP           ' Microsoft XML v3.0 (or later) must be referenced in Tools > References.
'Private Const sURL_Base As String = "http://www.google.com/"

Public Sub sVBS_Swarm()
' Note: this procedure uses independent VBScript files
'       you may need to authorize each once when they run for the first time, depending on your security settings.
    Call sVBScriptAgent(lgAgent:=1, _
                        strURL:="http://www.google.com/", _
                        wsReport:=wsX, _
                        sOutputRangeAddress:="A1")
End Sub

Public Sub sVBScriptAgent(ByRef lgAgent As Long, _
                          ByVal strURL As String, _
                          ByVal wsReport As Excel.Worksheet, _
                          ByVal sOutputRangeAddress As String)
' Worth looking: https://www.softwaretestinghelp.com/vbscript-excel-tutorial-11/
    Dim oWSH As Object ' As New ShellWindows ' Windows Scripting Host
    Dim iFileOut As Integer
    Dim sFileName As String
    Dim s As String
    
    ' Create VBScript string
    s = s & "Option Explicit" & vbCrLf
    s = s & "Dim oXML" & vbCrLf         ' Object for the MSXML2.XMLHTTP
    s = s & "Dim sHTML" & vbCrLf        ' Variable for HTML content
    s = s & "Dim vResults" & vbCrLf     ' Variable to hold parsed data
    s = s & vbCrLf
    
's = s & "Call sExcelReport" & vbCrLf
's = s & "  'WScript.Quit" & vbCrLf
's = s & vbCrLf
    
'    s = s & "' Create core objects" & vbCrLf
'    s = s & "Set oXML = WScript.CreateObject(""MSXML2.ServerXMLHTTP"")" & vbCrLf
'    s = s & vbCrLf
'    s = s & "' Navigate to property page" & vbCrLf
'    s = s & "oXML.Open ""GET"", """ & strURL & """, False" & vbCrLf
'    s = s & "oXML.setRequestHeader ""User-Agent"", ""Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)""" & vbCrLf
'    s = s & "'oXML.setRequestHeader ""Content-Type"", ""text/xml"" ' only to retrieve text" & vbCrLf
'    s = s & "'oXML.setRequestHeader ""Content-type"", ""application/text"" ' this may also work for text" & vbCrLf
'    s = s & "WScript.Sleep 50" & vbCrLf
'    s = s & "oXML.send("""")" & vbCrLf
'    s = s & "' wait until completion" & vbCrLf
'    s = s & "If oXML.Status = 200 Then ' check if internet connection status = True " & vbCrLf
'    s = s & "  Do Until oXML.ReadyState = 4" & vbCrLf
'    s = s & "    WScript.Echo oXML.ReadyState" & vbCrLf ' Test...
'    s = s & "  Loop" & vbCrLf
'    s = s & vbCrLf
'    s = s & "  ' Get Html content" & vbCrLf
'    s = s & "  sHTML = oXML.responseText" & vbCrLf
'    s = s & "Else" & vbCrLf
'    s = s & "  MsgBox ""No internet connection"", vbInformation, ""Internet connection"" & vbCrLf" & vbCrLf
'    s = s & "  'WScript.Quit" & vbCrLf
'    s = s & "End If" & vbCrLf
'    's = s & "WScript.Echo sHTML" & vbCrLf ' Test...
    s = s & "Call sExcelReport" & vbCrLf
    s = s & "Set oXML = Nothing" & vbCrLf
    s = s & vbCrLf

    's = s & "WScript.Echo ""Test""" & vbCrLf ' Test...
    s = s & "Private Sub sExcelReport()" & vbCrLf
    s = s & "' Write back results to Excel" & vbCrLf
    s = s & "  Dim oXLApp" & vbCrLf       ' Object for the Excel.Application
    s = s & "  Dim oXLWbk" & vbCrLf       ' Object for the Excel.Workbook
    s = s & "  Dim oXLWsh" & vbCrLf       ' Object for the Excel.Worksheet
    s = s & "  Dim oXLRng" & vbCrLf       ' Object for the Excel.Range
    s = s & vbCrLf
    s = s & "  ' Get running Excel instance (or open one if needed)" & vbCrLf
    s = s & "  'On Error Resume Next" & vbCrLf
    s = s & "  Set oXLApp = GetObject(, ""Excel.Application"")" & vbCrLf
        ' Note, do not use:
        ' WScript.GetObject("", "Excel.Application") as it will be referred to WSH DOM elements and will not find the running Excel instance
        ' GetObject("""", "Excel.Application") as it will again be referred to WSH DOM elements and will not find the running Excel instance
    s = s & "  If Err.Number <> 0 Then" & vbCrLf
    s = s & "    If Err.Number = 429 Then 'No current instance of Excel start up Excel" & vbCrLf
    s = s & "      Err.Clear" & vbCrLf
    s = s & "      'WScript.Quit" & vbCrLf
    s = s & "      'If xlApp <> ""Microsoft Excel"" Then" & vbCrLf
    s = s & "      '  Set xlApp = CreateObject(""Excel.Application"")" & vbCrLf
    s = s & "      'End If" & vbCrLf
    s = s & "    End If" & vbCrLf
    s = s & "  End If" & vbCrLf
    s = s & "  'If TypeName(oXLApp) = ""Empty"" Then" & vbCrLf
    s = s & "  '  MsgBox ""Excel NOT Running"", vbInformation, ""Excel Status"" & vbCrLf" & vbCrLf
    s = s & "  '  'WScript.Quit" & vbCrLf
    s = s & "  'End If" & vbCrLf
    s = s & "  On Error Resume Next" & vbCrLf
    's = s & "  oXLApp.Visible = True" & vbCrLf
    s = s & vbCrLf
    
    s = s & "  'If oXLApp.Workbooks.Count > 0 Then" & vbCrLf
    s = s & "    'For Each oXLWbk In oXLApp.Workbooks" & vbCrLf
    's = s & "    On Error Resume Next" & vbCrLf
    s = s & "    Set oXLWbk = oXLApp.WorkBooks(""" & ThisWorkbook.Name & """)" & vbCrLf
    s = s & "    oXLWbk.Activate" & vbCrLf
    's = s & "    If Err <> 0 Then" & vbCrLf
    's = s & "     ' unable to activate, so workbook was not open -> open it now" & vbCrLf
    's = s & "      Dim fullPath: fullPath = InputBox(""Give full path and name for workbook"", , oXLApp.ActiveWorkbook.Name)" & vbCrLf
    's = s & "      If Not vbYes = MsgBox(""Open workbook ["" & fullPath & ""]?"", vbYesNo) Then 'WScript.Quit" & vbCrLf
    's = s & "      'Set oXLWbk = oxlApp.Workbooks.Open(fullPath, 0, True)" & vbCrLf
    's = s & "      Set oXLWbk = oxlApp.ActiveWorkbook" & vbCrLf
    's = s & "    End If" & vbCrLf
    's = s & "    Err.Clear" & vbCrLf
    's = s & "    On Error GoTo 0" & vbCrLf
    s = s & "    Set oXLWsh = oXLWbk.Sheets(""" & ActiveSheet.Name & """)" & vbCrLf
    s = s & "    Set oXLRng = oXLWsh.Range(""A1"")" & vbCrLf
    s = s & "    'WScript.Echo oXLApp.Name & "" > "" & oXLWbk.Name & "" > "" & oXLWsh.Name & "" > "" & oXLRng.Value" & vbCrLf
    s = s & "    oXLRng.Value = sHTML" & vbCrLf
    s = s & "    'Next" & vbCrLf
    s = s & "  'End If" & vbCrLf
    s = s & "  'Exit Sub" & vbCrLf
    
'----------------
    ' to run the desired macro in the excel file
    s = s & "oXLApp.Run ""sTestHiddenData""" & vbCrLf
'----------------
    
    's = s & "  'Wscript.Sleep Int(Rnd * (800 + 1 - 350)) + 350" & vbCrLf ' Wait a random number [350-800 msec]... to avoid ban
    
    s = s & "  'oXLWbk.Saved = True" & vbCrLf
    s = s & "  'oXLApp.Activewindow.Close" & vbCrLf
    s = s & "  'oXLApp.Quit" & vbCrLf
    s = s & vbCrLf
    s = s & "  Set oXLRng = Nothing" & vbCrLf
    s = s & "  Set oXLWsh = Nothing" & vbCrLf
    s = s & "  Set oXLWbk = Nothing" & vbCrLf
    s = s & "  Set oXLApp = Nothing" & vbCrLf
    s = s & "End Sub" & vbCrLf


    ' Write other functions
    s = s & fVBSOtherFunctions
    
    ' Output VBScript to file (set lgAgent flag to keep track of the agent)
    sFileName = ThisWorkbook.Path & "\" & "Agent_" & lgAgent & ".vbs"
    iFileOut = VBA.FreeFile()
    Open sFileName For Output As iFileOut
    Print #iFileOut, s
    Close iFileOut
    s = vbNullString
    DoEvents
    
    ' Run VBScript file
    Set oWSH = CreateObject("Wscript.Shell")
    oWSH.Run """" & sFileName & """"
    
    '' Kill script file once executed
    'Sleep (1000)
    'Kill sFileName
    
    DoEvents
    Set oWSH = Nothing
End Sub
   
Private Function fVBSOtherFunctions() As String
' Other functions
    Dim s As String
    
    ' to check for internet connection (avoid getting trapped without connection)
    's = s & "Function Is_Connected() 'As Boolean" & vbCrLf
    's = s & "Dim MyLoop" & vbCrLf
    's = s & "Dim strComputer" & vbCrLf
    's = s & "Dim objPing" & vbCrLf
    's = s & "Dim objStatus" & vbCrLf
    's = s & vbCrLf
    's = s & "MyLoop = True" & vbCrLf
    's = s & "While MyLoop = True" & vbCrLf
    's = s & "  strComputer = ""smtp.gmail.com""" & vbCrLf
    's = s & "  Set objPing = GetObject(""winmgmts:{impersonationLevel=impersonate}!\\"").ExecQuery(""select * from Win32_PingStatus where address = '"" & strComputer & ""'"")" & vbCrLf
    's = s & "  For Each objStatus In objPing" & vbCrLf
    's = s & "    If objStatus.Statuscode = 0 Then" & vbCrLf
    's = s & "       MyLoop = False" & vbCrLf
    's = s & "       Is_Connected = (InternetGetConnectedState(IEStat, 0&) <> 0)" & vbCrLf
    's = s & "       'WScript.Quit" & vbCrLf
    's = s & "    End If" & vbCrLf
    's = s & "  Next" & vbCrLf
    's = s & "  pause (10) 'To sleep for 10 secondes" & vbCrLf
    's = s & "Wend" & vbCrLf
    
    ' will this work on VBScript???
    's = s & "Private Declare Function InternetGetConnectedState Lib ""wininet.dll"" (ByRef dwFlags As Long, ByVal dwReserved As Long) As Boolean" & vbCrLf
    's = s & "Function Is_Connected() As Boolean" & vbCrLf
    's = s & "Dim IEStat As Long" & vbCrLf
    's = s & "Is_Connected = (InternetGetConnectedState(IEStat, 0&) <> 0)" & vbCrLf
    's = s & "End Function" & vbCrLf

    s = s & vbCrLf & "'----------------------------" & vbCrLf
    
    fVBSOtherFunctions = s
End Function

In the fVBSOtherFunctions we will need a parser for the HTML code. This will be achieved through the MSMXL2.XMLHTTP object, DOM elements and nodes.

Get track of agents in use. We can share variables in-between workbooks over the same Excel instance (application), via the Hidden Space Name (more on www.cpearson.com/excel/hidden.htm), so running a tracker can refresh data of any thread. Here a little sample that shows the basic procedures:

Private Sub sTestHiddenData()
    Call WriteHiddenData("Variable", "")
    MsgBox ReadHiddenData("Variable")
    Call DeleteHiddenData("Variable")
End Sub

Private Sub WriteHiddenData(ByRef VarName As String, _
                            Optional ByRef VarValue As String = vbNullString)
' creates and assigns a value to a data item in Excel's hidden data store
' or
' assigns a value to an existing named item in the hidden data store
    Application.ExecuteExcel4Macro "SET.NAME(""" & VarName & """, """ & VarValue & """)"
End Sub

Private Function ReadHiddenData(ByRef VarName As String) As String
' reads a data value from Excel's hidden data store
    ReadHiddenData = Application.ExecuteExcel4Macro(VarName)
End Function

Private Sub DeleteHiddenData(ByRef VarName As String)
' deletes a data value from Excel's hidden data store
    Application.ExecuteExcel4Macro "SET.NAME(""" & VarName & """)"
End Sub

From Mikael Katajamäki blog, I take a piece of code and corrected it “severely”, as it was not working as expected. I realised of some points after this operation, and showed me that, at the end, I was taming the topic. Here is the code cleaned and with the propper functions. Note: You will need the API Sleep function, already declared in the code chunks above.

Option Explicit

' common text file for results from all Excel threads
'Private Const resultsFilePathName As String = VBA.Environ$("UserProfile") & "\Documents\shared.txt"
Dim resultsFilePathName As String

Public Sub CreateExcelThreads()
' create (and execute) Excel workbook threads
    Dim XlThreadhsPath As String
    Dim nThreads As Integer
    Dim XlThreadName As String
    Dim i As Integer
    Dim strExt As String
    
    XlThreadhsPath = VBA.Environ$("UserProfile") & "\Documents\"
    resultsFilePathName = XlThreadhsPath & "shared.txt"
    
    ' clean results text file
    If VBA.Dir(resultsFilePathName) <> vbNullString Then Kill resultsFilePathName

    nThreads = 1
    For i = 1 To nThreads
        strExt = "xls"
        XlThreadName = "XlThread_" & VBA.CStr(i)
        ExecuteExcelThread "SomeComplexAlgorithm", XlThreadName, XlThreadhsPath
    Next i
End Sub

Public Function ExecuteExcelThread(ByVal ProcedureName As String, _
                                   ByVal XlThreadName As String, _
                                   ByVal XlThreadhsPath As String, _
                                   Optional ByVal strExt As String = "xls")
    Dim ExcelThreadFilePathName As String
    Dim VBScriptFilePathName As String
    Dim s As String

    ' save a copy of current active workbook
    ExcelThreadFilePathName = XlThreadhsPath & XlThreadName & "." & strExt
    ProcedureName = XlThreadName & "." & strExt & "!" & ProcedureName
        ' If procedure is Public declared, then it can be called just by: ProcedureName = ProcedureName
    VBScriptFilePathName = XlThreadhsPath & XlThreadName & ".vbs"
    ActiveWorkbook.SaveCopyAs ExcelThreadFilePathName

    ' re-open previously saved Excel workbook
    s = s & "Set oXLApp = CreateObject(""Excel.Application"")" & vbLf
    s = s & "Set oXLWbk = oXLApp.Workbooks.Open(""" & ExcelThreadFilePathName & """)" & vbLf
    s = s & "oXLApp.Visible = True" & vbLf
    
    ' run target VBA program and close Excel workbook
    s = s & "oXLWbk.Application.Run """ & ProcedureName & """" & vbLf
    s = s & "oXLApp.ActiveWorkbook.Close True" & vbLf
    s = s & "oXLApp.Application.Quit" & vbLf
    
    ' delete copies of Excel workbook and VB script
    s = s & "CreateObject(""Scripting.FileSystemObject"").DeleteFile (""" & ExcelThreadFilePathName & """)" & vbLf
    s = s & "CreateObject(""Scripting.FileSystemObject"").DeleteFile (""" & VBScriptFilePathName & """)" & vbLf
    
    Dim iFileVBS As Integer
    iFileVBS = VBA.FreeFile()
    Open VBScriptFilePathName For Output Shared As #iFileVBS
    Print #iFileVBS, s
    Close #iFileVBS
    
    ' execute VB script
    Dim oWSh As Object
    Set oWSh = VBA.CreateObject("WScript.Shell")
    oWSh.Run VBScriptFilePathName
    Set oWSh = Nothing
End Function

'-------------

Public Sub SomeComplexAlgorithm()
' this is target program to be executed by Excel thread
' program creates N random numbers between 1 and 10, stores these into
' collection and finally prints the content into a specific text file
    Dim simulationResult As New Collection
    Dim i As Integer
    
    For i = 1 To 25
        ' due to brevity reasons, we just simulate some time-consuming algorithm
        Dim delayTime As Long
        delayTime = WorksheetFunction.RandBetween(1, 10)
        Sleep delayTime * 1000
        
        ' store one simulated result (random delay time) into collection
        simulationResult.Add delayTime
    Next i
    
    ' print result collection into a specific text file
    ' we have to be prepared for the case in which multiple users (Excel threads)
    ' are accessing the same specific text file at the same time

recoveryPoint:
    On Error GoTo errorHandler

    ' if the file is in use, error will be thrown below here
    Dim iFileOut As Integer
    iFileOut = VBA.FreeFile()
    Open resultsFilePathName For Append As #iFileOut
    For i = 1 To simulationResult.Count
        Print #iFileOut, ActiveWorkbook.Name & "=" & VBA.CStr(simulationResult(i))
    Next i
    Close #iFileOut
    Set simulationResult = Nothing
    Exit Sub
    '
errorHandler:
    ' get one second delay and re-access text file
    Sleep 1000
    Resume recoveryPoint
End Sub

Do not overload system with Excel instances
Aside from calling the threads through new Excel instaces, we can get the same effect launching the threads as pure VBScript code. But to achieve this, we need to convert any threadable VBA code to a “string of code”, just to create the VB template procedure awaiting the VBE to send that chunck of code to the VBScript or to be properly run in another independent thread.
So here is my last share, a macro that can load any procedure (or even an entire module), of pure VBA code and get it “stringified”.

Private Function fVBAToString(ByRef aLine() As String) As String
' convert a procedure to VBScript
    Dim aTmp() As String
    Dim strLine As String
    Dim lgLine As Long
    Dim lgCode As Long
    Dim lgPos As Long
    Dim lgComment As Long
    Dim bComment As Boolean

    ' Join multiline
    For lgLine = UBound(aLine) To LBound(aLine) + 1 Step -1
        strLine = VBA.RTrim$(aLine(lgLine - 1))
        If VBA.Right$(strLine, 2) = " _" Then
            aLine(lgLine - 1) = VBA.Mid$(strLine, 1, VBA.Len(strLine) - 1) & VBA.Trim$(aLine(lgLine))
            aLine(lgLine) = "'¤"
        End If
    Next lgLine
        
    lgCode = -1
    For lgLine = LBound(aLine) To UBound(aLine)
        If Not aLine(lgLine) Like "'¤" Then
            lgCode = lgCode + 1
            ReDim Preserve aTmp(0 To lgCode)
            aTmp(lgCode) = aLine(lgLine)
        End If
    Next lgLine
    aLine() = aTmp()
    Erase aTmp()
    strLine = vbNullString
    
    For lgLine = LBound(aLine) To UBound(aLine)
        ' In aLine(lgLine), replace ["] chars out of comments
        lgComment = 0
        bComment = False
        lgPos = 1
        Do Until lgPos > VBA.Len(aLine(lgLine))
            If VBA.Mid$(aLine(lgLine), lgPos, 1) = """" Then
                aLine(lgLine) = VBA.Mid$(aLine(lgLine), 1, lgPos) _
                              & """" _
                              & VBA.Mid$(aLine(lgLine), lgPos + 1)
                lgPos = lgPos + 1
                
                If Not bComment Then
                    lgComment = lgComment + 1
                    'If (lgComment - 1) Mod 2 = 0 Then
                        ' Opens comment ... whatever is next is comment
                    'Else
                        ' Closes comment ... whatever is next is code
                    'End If
                End If
            ElseIf VBA.Mid$(aLine(lgLine), lgPos, 1) = "'" Then
                If lgComment Mod 2 = 0 Then
                    ' Opens comment ... whatever is next is comment
                    bComment = True
                End If
            End If
            lgPos = lgPos + 1
        Loop
        aLine(lgLine) = """" & aLine(lgLine) & """"
    Next lgLine
    
    fVBAToString = "  s = s & " & VBA.Join(aLine, " & vbCrLf" & vbCrLf & "  s = s & ")
    
End Function

2 thoughts on “EXCEL VBA MULTITHREADING”

  1. I don’t even know how I ended up here, but I thought this post was good. I do not know who you are but definitely you’re going to a famous blogger if you are not already 😉 Cheers!

Leave a Reply

Your email address will not be published. Required fields are marked *