4

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

我看过这个教程，但它不起作用。

我有 10000 个站点，每个站点在 A 列的一行中。我需要至少 10 个并发线程来解析标签之间的信息，从每个站点的 index.php 中<div></div>获取标签，然后将结果保存到 B 列中的每一行。<a>rel="external"

4

3 回答 3

8

您可以在 VBA 中使用多线程，但不能在本地使用。然而，在 VBA 中实现多线程有几种可能性：

  1. C#.NET COM/dlls - 在 C#.NET 中创建一个 COM/dll，它允许您自由创建线程并像其他外部库一样从 VBA 引用它。请参阅我的帖子：here。另请参阅有关从 VBA 中引用 C# 方法的 Stackoverflow 帖子：在 EXCEL VBA 中使用 C# dll
  2. VBscript 工作线程- 将您的算法划分为尽可能多的 VBscript 线程，并从 VBA 执行它们。VBscripts 可以通过 VBA 自动创建。请参阅我的帖子：这里
  3. VBA 工作线程- 根据需要多次复制 Excel 工作簿，并通过 VBA 中的 VBscript 执行它们。VBscripts 可以通过 VBA 自动创建。请参阅我的帖子：这里

我分析了所有这些方法，并对优缺点和一些性能指标进行了比较。你可以在这里找到整个帖子：

http://analystcave.com/excel-multithreading-vba-vs-vbscript-vs-c-net/

于 2014-11-16T01:04:00.617 回答
7

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

一个很好的例子是Application.OnTime。它允许程序在将来的某个时间点运行。

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

For a = 1 To 500000000
Next a

我机器上的 For...Next 循环大约需要 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”，即伪多线程。

好吧，这不会发生。运行上面的代码将显示，Application.OnTime 必须耐心等待，直到 For...Next 循环完成。

于 2013-10-03T13:27:39.887 回答
0

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

示例：每 600 毫秒（毫秒）运行一次 subA，每 200 毫秒运行一次 SubB，以便顺序为：SubB,SubB,SubB,SubA,SubB,SubB,SubB,SubA,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

我不是专业的编码员，所以我相信其他人可以做得更好，但它运行得相当好。大部分代码只是管理可能可以更有效地完成的队列。

除了 SetTimer，您还可以创建按计划触发的线程，使用鼠标或键盘事件，甚至在活动窗口中用于屏幕抓取像素。

当您在设计时不知道何时激活代码时，线程很有用。例如：

您为在线锦标赛扑克创建扑克 HUD+DB。一个线程可以每几百毫秒运行一次以等待触发器，例如当新手开始时，您读取最后一个 HH 并更新数据库和 hud，或者新玩家加入表并在锦标赛跟踪站点上进行自动查找。另一个线程可能每秒运行一次以更新显示在您的 hud 上的锦标赛时钟，并在级别更改之前提供 3 分钟警告等等。

您甚至可以创建一个单独的 shell 脚本来运行一个线程，该线程会自动加入您提前安排的新锦标赛，然后它可以为您玩的每个牌桌启动一个新的脚本副本。我不确定启动多个脚本副本或运行来自不同项目的脚本是否可以使用 VBA 真正实现多线程，但根据我在论坛中看到的内容，我有点怀疑。

请注意，虽然它运行时没有错误，但我做了一些更改以清理它并引入了一些我从未有机会修复的小错误。

于 2014-07-10T20:50:45.030 回答