Multithreading VBA-Excel中的多线程处理

如何在VBA中编写代码以获得多线程解析

我看过了，但它不起作用

---

我有10000个站点，每个站点在A列的一行中。我需要至少10个并发线程来解析标记之间的信息

，在每个站点上使用index.php中的

rel=“external”

，然后将结果保存到B列的每一行。

正如@Siddharth Rout在他的评论中指出的那样，答案是否定的。但要对此稍作扩展，即使是在后台运行并启用类似多线程功能的方法也不允许使用多线程

这方面的一个很好的例子是。它允许在将来的某个时间点运行一个过程

此方法允许用户继续编辑工作簿，直到经过预设的时间量并调用该过程。乍一看，聪明地使用它可能会使多个代码片段同时运行。考虑下面的片段：

For a = 1 To 500000000
Next a

我机器上的下一个循环大约需要5秒钟才能完成。现在考虑这个问题：

Application.OnTime Now + TimeValue("00:00:1"), "ztest2"
For a = 1 To 500000000
Next a

这将在读取Application.OnTime语句一秒钟后调用“ztest2”。可以想象，由于For…Next循环需要5秒，.OnTime将在1秒后执行，因此可能会在For…Next循环中调用“ztest2”，即psuedo多线程

---

但事实并非如此。正如运行上述代码所示，Application.OnTime必须耐心等待，直到For…Next循环完成。

虽然您不能执行真正的多线程，即在不同的内核上同时并行运行线程，但您可以通过将多线程的操作排队来模拟多线程代码

例如： 每600毫秒（毫秒）运行一次subA，每200毫秒运行一次SubB，顺序如下： SubB，SubB，SubB，SubA，SubB，SubB，SubB，SubA，SubB，SubB，SubB

'Create a new class Tick_Timer to get access to NumTicks which counts ticks in
'milliseconds.
'While not used for this script, this class can also be used for a millisecond
'StartTimer/EndTimer which I included below.
'It can also be used to create a pause, similar to wait but in ms, that can
'allow other code to run while paused which I prefer over the sleep function.
'Sleep doesn't allow interruptions and hogs processor time. 
'The pause function would be placed in a module and works similar to the
'Queue Timer loop which I'll explain below.
Private StartTick As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Public Function GetNumTicks() As Long
    GetNumTicks = GetTickCount
End Function

'Timer functions(not used in this script)
Public Sub StartTimer()
    StartTick = GetTickCount
End Sub

Public Function EndTimer() As Long
    EndTimer = (GetTickCount - StartTick)
End Function

在一个模块中，我声明了一些全局变量。虽然我知道很多人认为使用全局变量S是不好的做法。我总是为全局变量使用前缀，这样它们就不会与局部变量混淆

在这种情况下，全局变量比使用参数有优势，因为新线程可能会在队列中第一个计时器之前需要执行的任何时间被调用

全局变量可以在任何地方更改，以便动态更新队列。还考虑到几乎每个子例程都以某种方式使用队列，所以只需使用全局变量就更有意义了。

Public ST_TimerName As String 'Subroutine Name that is run as a new thread.

'Two strings are used to store the queue. 
'The first stores only the start times of each thread in tickcounts. 
'This allows me to sort the queue more easily.
'The second string (ST_TimerQ) contains TimerDelay:TimerName and is created at the
'same time as the sorted launch times so they are kept synchronous.
Public ST_EndTickQ As String  'queue string: trigger times in TickCounts.
Public ST_TimerQ As String    'queue string: TimerDelay:TimerName 

'New class that allows you to get the current Tick Count.
Public ST_Timer As Tick_Timer 'timer that accesses to Tick Count

Sub SetTimer(ByVal TimerName As String, ByVal TimerDelay As Long)
'Starts a new thread called TimerName which executes after TimerDelay(ms)
'TimerName: Name of subroutine that is to be activated.
'TimerDelay:
'-value for single execution after abs(-value) delay,
'+value Repeats TimerName with a period of TimerDelay.
'0 stops repeating TimerName.
    Dim EndTick As Long
    Dim TimerDat As String

    Set ST_Timer = New Tick_Timer
    EndTick = ST_Timer.GetNumTicks + Abs(TimerDelay)

    If TimerDelay = 0 Then
    'Stops TimerName
        RemoveFromQ TimerName
    Else
    'Insert to Queue, single or repeated is determined by +/-delay stored in TimerDat.
        TimerDat = TimerDelay & ":" & TimerName
        Call AddToQ(TimerDat, EndTick)
    End If
End Sub 'SetTimer

Sub SetTimerQLoop()
'All threads are continuously merged into an action queue with a sequential
'insertion sort.
'A simple loop containing only the DoEvents function(allows other VBA code to run) 
'loops until the the next thread in the queue needs to start.
'An outer loop runs through the queue until EOQ.
    Dim EndTick As Long
    Dim EOQ As Boolean

    On Error GoTo ErrHandler
    EOQ = False
    'SetTimer Queue Loop
    Do While Not (EOQ)
        'Delay Loop, DoEvents allows other vba scripts to run during delay.
        Do
            DoEvents
        Loop Until ST_Timer.GetNumTicks >= Val(ST_EndTickQ)

        Application.Run ST_TimerName

        If Val(ST_TimerQ) > 0 Then
        'Reinsert into queue threads with pos delay value.
            EndTick = Val(ST_EndTickQ) + Val(ST_TimerQ)
            TimerDat = Val(ST_TimerQ) & ":" & ST_TimerName
            Call AddToQ(TimerDat, EndTick)
        End If

        If ST_TimerQ = vbNullString Then
            EOQ = True
        Else
            GetNextQ
        End If
    Loop
Exit Sub
ErrHandler:
    'Break Key
End Sub 'SetTimerQLoop

Sub AddToQ(ByVal TimerDat As String, ByVal EndTick As Long)
    Dim EndTickArray() As String
    Dim TimerArray() As String
    Dim LastTickIndex As Integer
    Dim LastTimerIndex As Integer

    Dim PosDatDel As Integer
    Dim TimerDelay As Long
    Dim TimerName As String
    Dim QFirstTick As Long
    Dim QLastTick As Long

    PosDatDel = Len(TimerDat) - InStr(TimerDat, ":")
    TimerDelay = Val(TimerDat)
    TimerName = Right(TimerDat, PosDatDel)

    If ST_EndTickQ = vbNullString Then
    'First timer
        ST_TimerName = TimerName
        ST_EndTickQ = EndTick
        ST_TimerQ = TimerDat
        SetTimerQLoop
    ElseIf InStr(ST_EndTickQ, "|") = 0 Then
    'Second timer
        If EndTick < Val(ST_EndTickQ) Then
        'New timer is first of 2 in Q
            ST_TimerName = TimerName
            ST_EndTickQ = EndTick & "|" & ST_EndTickQ
            ST_TimerQ = TimerDat & "|" & ST_TimerQ
        Else
        'New timer is 2nd of 2 in Q
            ST_TimerName = TimerNameF(ST_TimerQ)
            ST_EndTickQ = ST_EndTickQ & "|" & EndTick
            ST_TimerQ = ST_TimerQ & "|" & TimerDat
        End If
    Else
    '3rd+ timer: split queue into an array to find new timers position in queue.
        TimerArray = Split(ST_TimerQ, "|")
        LastTimerIndex = UBound(TimerArray)
        EndTickArray = Split(ST_EndTickQ, "|")
        LastTickIndex = UBound(EndTickArray)
        ReDim Preserve EndTickArray(LastTickIndex)
        ReDim Preserve TimerArray(LastTimerIndex)
        QFirstTick = Val(ST_EndTickQ)
        QLastTick = Val(EndTickArray(LastTickIndex))

        If EndTick < QFirstTick Then
        'Front of queue
            ST_EndTickQ = EndTick & "|" & ST_EndTickQ
            ST_TimerQ = TimerDat & "|" & ST_TimerQ
            ST_TimerName = Val(ST_TimerQ)
        ElseIf EndTick > QLastTick Then
        'Back of queue
            ST_TimerName = TimerNameF(ST_TimerQ)
            ST_EndTickQ = ST_EndTickQ & "|" & EndTick
            ST_TimerQ = ST_TimerQ & "|" & TimerDat
        Else
        'Somewhere mid queue
            For i = 1 To LastTimerIndex
                If EndTick < EndTickArray(i) Then
                    ST_EndTickQ = Replace(ST_EndTickQ, EndTickArray(i - 1), _
                    EndTickArray(i - 1) & "|" & EndTick)
                    ST_TimerQ = Replace(ST_TimerQ, TimerArray(i - 1), _
                    TimerArray(i - 1) & "|" & TimerDat)
                    Exit For
                End If
            Next i
            ST_TimerName = TimerNameF(ST_TimerQ)
        End If
    End If
End Sub 'AddToQ

Sub RemoveFromQ(ByVal TimerName As String)
    Dim EndTickArray() As String
    Dim TimerArray() As String
    Dim LastTickIndex As Integer
    Dim LastTimerIndex As Integer
    Dim PosDel As Integer

    PosDel = InStr(ST_EndTickQ, "|")

    If PosDel = 0 Then
    'Last element remaining in queue
        ST_EndTickQ = vbNullString
        ST_TimerQ = vbNullString
        ST_TimerName = vbNullString
    Else
    '2+ elements in queue
        TimerArray = Split(ST_TimerQ, "|")
        LastTimerIndex = UBound(TimerArray)
        EndTickArray = Split(ST_EndTickQ, "|")
        LastTickIndex = UBound(EndTickArray)
        ReDim Preserve EndTickArray(LastTickIndex)
        ReDim Preserve TimerArray(LastTimerIndex)
        ST_TimerQ = vbNullString
        ST_EndTickQ = vbNullString
        For i = 0 To LastTimerIndex
            If InStr(TimerArray(i), TimerName) = 0 Then
                If ST_TimerQ = vbNullString Then
                    ST_TimerQ = TimerArray(i)
                    ST_EndTickQ = EndTickArray(i)
                    X = Len(ST_TimerQ) - InStr(ST_TimerQ, ":")
                    ST_TimerName = Right(ST_TimerQ, X)
                Else
                    ST_TimerQ = ST_TimerQ & "|" & TimerArray(i)
                    ST_EndTickQ = ST_EndTickQ & "|" & EndTickArray(i)
                End If
            End If
        Next i
    End If
End Sub 'RemoveFromQ

Sub GetNextQ()
    Dim PosDel As Integer

    PosDel = InStr(ST_EndTickQ, "|")
    If PosDel = 0 Then
    'Last element remaining in queue
        ST_EndTickQ = vbNullString
        ST_TimerQ = vbNullString
        ST_TimerName = vbNullString
    Else
    '2+ elements in queue
        ST_EndTickQ = Right(ST_EndTickQ, Len(ST_EndTickQ) - PosDel)
        ST_TimerQ = Right(ST_TimerQ, Len(ST_TimerQ) - InStr(ST_TimerQ, "|"))
        ST_TimerName = TimerNameF(ST_TimerQ)
    End If
End Sub 'GetNextQ

Public Function TimerNameF(ByVal TimerQ As String) As String
    Dim StrLen As Integer
    If InStr(ST_TimerQ, "|") Then
        StrLen = InStr(ST_TimerQ, "|") - InStr(ST_TimerQ, ":") - 1
    Else
        StrLen = Len(ST_TimerQ) - InStr(ST_TimerQ, ":")
    End If
    TimerNameF = Mid(ST_TimerQ, InStr(ST_TimerQ, ":") + 1, StrLen)
End Function

Sub TestSetTimer1()
'Call SubA every 5 seconds
    Call SetTimer("SubA", 600)
End Sub

Sub TestSetTimer2()
'Call SubB every second
    Call SetTimer("SubB", 200)
End Sub

Sub TestSetTimer3()
'Stop calling SubA
    Call SetTimer("SubA", 0)
End Sub

Sub TestSetTimer4()
'Stop calling SubB
    Call SetTimer("SubB", 0)
End Sub

Sub TestSetTimer5()
'Call SubC one time after a 3 second delay.
    Call SetTimer("SubC", -3000)
End Sub


Sub SubA()
    Debug.Print "SubA Queue: " & ST_TimerQ & ", EndTickQ: " & ST_EndTickQ
End Sub

Sub SubB()
    Debug.Print "SubB Queue: " & ST_TimerQ & ", EndTickQ: " & ST_EndTickQ
End Sub

Sub SubC()
    Debug.Print "SubC Queue: " & ST_TimerQ & ", EndTickQ: " & ST_EndTickQ
End Sub

Public ST_TimerName As String'作为新线程运行的子例程名称。
'两个字符串用于存储队列。
'第一个仅以tickcounts存储每个线程的开始时间。
'这使我可以更轻松地对队列进行排序。
'第二个字符串（ST_TimerQ）包含TimerDelay:TimerName，并在
'与排序的启动时间相同，因此它们保持同步。
Public ST_EndTickQ As String'队列字符串：以TickCounts为单位的触发时间。
公共ST_TimerQ As String'队列字符串：TimerDelay:TimerName
'允许您获取当前滴答数的新类。
公共ST_Timer作为Tick_Timer访问Tick Count的计时器
子设置计时器（ByVal TimerName为字符串，ByVal TimerDelay为长）
'启动一个名为TimerName的新线程，该线程在TimerDelay（毫秒）之后执行
'TimerName:要激活的子例程的名称。
“TimerDelay：
'-abs（-value）延迟后单次执行的值，
“+值以一段时间重复TimerName显示。
“0停止重复TimerName。
暗尾鳍一样长
Dim TimerDat As字符串
设置ST_定时器=新的滴答定时器
EndTick=ST_Timer.GetNumTicks+Abs（TimerDelay）
如果TimerDelay=0，则
”他叫道
RemoveFromQ TimerName
其他的
'插入队列，单个或重复由存储在TimerDat中的+/-延迟决定。
TimerDat=TimerDelay&“：”&TimerName
调用AddToQ（TimerDat，EndTick）
如果结束
“结束子”设置计时器
Sub-SetTimerQLoop（）
'所有线程都连续合并到一个具有顺序
'插入排序。
'仅包含DoEvents函数的简单循环（允许运行其他VBA代码）
'循环，直到队列中的下一个线程需要启动。
'外部循环在队列中运行，直到EOQ。
暗尾鳍一样长
作为布尔的弱EOQ
关于错误转到错误处理程序
EOQ=错误
'设置计时器队列循环
做而不做（EOQ）
'延迟循环，DoEvents允许其他vba脚本在延迟期间运行。
做
多芬特
循环直到ST_Timer.GetNumTicks>=Val（ST_EndTickQ）
应用程序。运行ST_TimerName
如果Val（ST_TimerQ）>0，则
'使用pos延迟值重新插入队列线程。
EndTick=Val（ST_EndTickQ）+Val（ST_TimerQ）
TimerDat=Val（ST_TimerQ）和“&ST_TimerName”
调用AddToQ（TimerDat，EndTick）
如果结束
如果ST_TimerQ=vbNullString，则
EOQ=真
其他的
GetNextQ
如果结束
环
出口接头
错误处理程序：
“断键
“结束子”SetTimerQLoop
Sub AddToQ（ByVal TimerDat为字符串，ByVal EndTick为长）
Dim EndTickArray（）作为字符串
Dim TimerArray（）作为字符串
将索引设置为整数
将LastTimerIndex设置为整数
作为整数的Dim PosDatDel
昏暗的时光如长
作为字符串的Dim TimerName
暗QFirstTick与长QFirstTick一样
变暗，变长
PosDatDel=Len（TimerDat）-InStr（TimerDat，“：”）
TimerDelay=Val（TimerDat）
TimerName=右（TimerDat，PosDatDel）
如果ST_EndTickQ=vbNullString，则
“第一个计时器
ST_TimerName=TimerName
ST_EndTickQ=EndTick
ST_TimerQ=TimerDat
SetTimerQLoop
ElseIf InStr（ST_EndTickQ，“|”）则=0
“第二个计时器
如果EndTick