VBA 数组运行非常缓慢的嵌套循环 - 寻找解决方案

Question

我正在运行一个嵌套循环，我向其中添加了一个数组以试图加快速度，但它仍然运行得相当慢。 当我在“活动”表中有 100 行和 41 列数据，在“已关闭”表中有 1000 行和 41 列数据时，运行代码和 output 数据到“CompSheet”大约需要 7 分钟

Sub CompareColumns()

    'Turn off screen updating and automatic calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim i As Integer 'variable for the outer loop
    Dim j As Integer 'variable for the inner loop
    Dim ws As Worksheet 'variable for the sheet CompSheet
    Dim compareLat As Byte 'variable for the column that is being compared
    Dim compareLon As Byte 'variable for the column that is being compared
    Dim compareLatArray As Byte
    Dim compareLonArray As Byte
    Dim uniqueID As String 'variable for the unique identifier
    Dim ActiveSheetRows As Integer
    Dim ClosedSheetRows As Integer
    
    Dim closedArray As Variant ' variable for closed sheet data
    Dim closedArrayRow As Variant
    
    Dim activeArray As Variant ' variable for active sheet data
    Dim activeArrayRow As Variant
    
    Dim dLon As Double
    Dim x As Double
    Dim y As Double
    Dim lat_a As Double
    Dim lat_c As Double
    Dim lon_a As Double
    Dim lon_c As Double
    Dim result As Double
    Dim distance_toggle As Single
    Dim distance As Single

    
    ActiveSheetRows = Worksheets("Active").UsedRange.Rows.Count
    ClosedSheetRows = Worksheets("Closed").UsedRange.Rows.Count
    
    compareLat = 38 'change this variable to switch the column that is being compared
    compareLon = 39 'change this variable to switch the column that is being compared
    compareLatArray = 38 'change this variable to switch the column that is being compared
    compareLonArray = 39 'change this variable to switch the column that is being compared
    
    distance_toggle = 1.5
    
    'Store the data from the "Closed" worksheet into the array
    closedArray = Worksheets("Closed").UsedRange.Value
    
    'Store the data from the "Active" worksheet into the array
    activeArray = Worksheets("Active").UsedRange.Value


    'Check if the sheet CompSheet exists, if not create it
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("CompSheet")
    If ws Is Nothing Then
    
        ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "CompSheet"
        
        'copy the header row from the "Closed" worksheet when it first creates the "CompSheet" worksheet
        Worksheets("Closed").Rows(1).Copy _
            Destination:=Worksheets("CompSheet").Range("A1")

        'Add the column header "uniqueID" to the last cell in row 1 of the "CompSheet" worksheet
        Worksheets("CompSheet").Cells(1, Worksheets("CompSheet").UsedRange.Columns.Count + 1).Value = "uniqueID"

        'Add the column header "CompDistance" to the last cell in row 1 of the "CompSheet" worksheet
        Worksheets("CompSheet").Cells(1, Worksheets("CompSheet").UsedRange.Columns.Count + 1).Value = "CompDistance"

    End If
    On Error GoTo 0

    'Loop through all the rows in the "Active" worksheet starting on row 2
    For i = 2 To UBound(activeArray, 1)

        'Loop through the array to look up the data in the "Closed" worksheet
        For j = 2 To UBound(closedArray, 1)
        
        lat_a = activeArray(i, compareLat)
        lat_c = closedArray(j, compareLatArray)
        lon_a = activeArray(i, compareLon)
        lon_c = closedArray(j, compareLonArray)

            'Calculationg for D2R = 0.0174532925199433
            'pi = 4 * Atn(1)
            'D2R = pi / 180#
            
        lat_a = 0.0174532925199433 * lat_a
        lat_c = 0.0174532925199433 * lat_c
        dLon = 0.0174532925199433 * (lon_c - lon_a)

        x = Sin(lat_a) * Sin(lat_c) + Cos(lat_a) * Cos(lat_c) * Cos(dLon)
        y = Sqr((Cos(lat_c) * Sin(dLon)) ^ 2 + (Cos(lat_a) * Sin(lat_c) - Sin(lat_a) * Cos(lat_c) * Cos(dLon)) ^ 2)

        distance = WorksheetFunction.Atan2(x, y) * 3963.19
    

        If distance <= distance_toggle Then
            
            'Copy the row from the Closed worksheet to the CompSheet worksheet in the next available row
            Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Insert
            
            closedArrayRow = Worksheets("Closed").Cells(j, 1).Resize(1, UBound(closedArray, 2))
            
            'Worksheets("CompSheet").Range("B1").Resize(UBound(closedArrayRow, 1), UBound(closedArrayRow, 2)).Value = closedArrayRow
            Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count).Resize(1, 41).Value = closedArrayRow
            
                
            'Create a uniqueID by combining column 6 from both the Active and Closed worksheets with a space and "&" in between
            uniqueID = activeArray(i, 5) & " " & "&" & " " & closedArray(j, 5)

            'Paste the uniqueID in the next available column of the new row in the CompSheet worksheet
            Worksheets("CompSheet").Cells(Worksheets("CompSheet").UsedRange.Rows.Count, compareLon + 1).Value = uniqueID

            'Paste the distance value in the corresponding column of the new row in the CompSheet worksheet
            Worksheets("CompSheet").Cells(Worksheets("CompSheet").UsedRange.Rows.Count, compareLon + 2).Value = distance
      
      End If
  Next j
Next i

            'Formatting "CompSheet" Data
            Worksheets("CompSheet").Columns.AutoFit
            Worksheets("CompSheet").Range("AO:AO").NumberFormat = "#,##0.0"
            Worksheets("CompSheet").UsedRange.Font.Bold = False
            Worksheets("CompSheet").Cells(1, 1).EntireRow.Font.Bold = True
            
            'Turn on screen updating and automatic calculation
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

End Sub

我添加了数组来尝试加快速度，但我不确定我是否正确实施了它们。 我还添加了一些其他代码来帮助提高速度（根据 OpenAI ChatGPT 的建议），例如：

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

任何帮助将不胜感激。

更新：请参阅下面的谷歌驱动器链接以获取实际的 excel 文件。 我已经运行了我的代码，它花了 8 分钟。 最终，我想将其扩展到这个大小的 500 倍左右的数据集。 根据线性时间计算，这将需要 60 个小时才能运行。

https://drive.google.com/file/d/1GfR5RbWcHFQC-5oY9izDOQWbzZkvBwXi/view?usp=share_link

我想做的是比较房地产列表（属性），当前在“活动”表中列出的待售属性与“已关闭”表中已售出的属性。 对于“活动”表中的每个属性（行），我需要代码根据距离切换检查“已关闭”表中的每个已售出的属性，如果已售出的属性在指定距离（2 英里）内，那么我想要将已售出的列表行从“已关闭”表复制到“CompSheet”中，并为该 comp 粘贴唯一 ID（两个地址连接）和“距离”变量。

Answer 1

到目前为止我发现不需要的一件事是：

Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Insert

这看起来像是在底部添加一行。 您不必将行添加到底部，它们已经存在 - 只需将其注释掉并将 1 添加到您的“复制”语句Rows.Count + 1 。

Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Resize(1, 41).Value = closedArrayRow

Answer 2

这应该更快。 编译，但未经测试。

• 使用工作表引用可以使您的代码更简洁。
• 将WorksheetFunction调用换成更快的 VBA 版本。
• 将数据添加到补偿表时跳过了Insert （正如 Nick 已经建议的那样）。
• 对固定值使用Const
• 避免UsedRange ，因为它可能不可靠/不可预测

Sub CompareColumns()

    Const NUM_COLS As Long = 39         
    Const ID_COL As Long = 40
    Const DIST_COL As Long = 41
    
    Const COL_ACT_LAT As Long = 38
    Const COL_ACT_LON As Long = 39
    Const COL_CLS_LAT As Long = 38
    Const COL_CLS_LON As Long = 39
    Const DIST_TOGGLE As Double = 1.5
    
    Dim wb As Workbook, wsActive As Worksheet, wsClosed As Worksheet, wsComp As Worksheet
    Dim rngClosed As Range, rngActive As Range
    Dim i As Long, j As Long
    Dim closedArray As Variant, activeArray As Variant
    Dim lat_a As Double, lat_c As Double, lon_a As Double, lon_c As Double
    Dim distance As Double, lastRw As Long, destRw As Range
    
    Set wb = ThisWorkbook
    Set wsActive = wb.Worksheets("Active")
    'if your data has no empty rows or columns
    Set rngActive = wsActive.Range("A1").CurrentRegion.Resize(, NUM_COLS)
    activeArray = rngActive.Value
    
    Set wsClosed = wb.Worksheets("Closed")
    Set rngClosed = wsClosed.Range("A1").CurrentRegion.Resize(, NUM_COLS)
    closedArray = rngClosed.Value
    
    'add the comparison sheet if not already present
    On Error Resume Next 'ignore error if sheet is missing
    Set wsComp = wb.Worksheets("CompSheet")
    On Error GoTo 0      'stop ignoring errors as soon as it's no longer needed....
    If wsComp Is Nothing Then
        Set wsComp = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
        wsComp.Name = "CompSheet"
        wsClosed.Range("A1").Resize(1, NUM_COLS).Copy wsComp.Range("A1")
        wsComp.Cells(1, ID_COL).Value = "uniqueID"
        wsComp.Cells(1, DIST_COL).Value = "CompDistance"
        lastRw = 1
    Else
        'find last row with any data
        lastRw = wsComp.Cells.Find(What:="*", SearchOrder:=xlByRows, _
                                   SearchDirection:=xlPrevious).Row
    End If
    Set destRw = wsComp.Rows(lastRw + 1) 'first empty row on comp sheet
    
    For i = 2 To UBound(activeArray, 1) 'loop "active" array

        lat_a = activeArray(i, COL_ACT_LAT) 'you can read these in the outer loop
        lon_a = activeArray(i, COL_ACT_LON)
        
        For j = 2 To UBound(closedArray, 1) 'loop "closed" array
        
            lat_c = closedArray(j, COL_CLS_LAT)
            lon_c = closedArray(j, COL_CLS_LON)
            distance = DistanceCalc(lat_a, lon_a, lat_c, lon_c)
        
            If distance <= DIST_TOGGLE Then
                destRw.Cells(1).Resize(1, NUM_COLS).Value = rngClosed.Rows(j).Value
                destRw.Cells(ID_COL).Value = activeArray(i, 5) & " " & "&" & " " & closedArray(j, 5)
                destRw.Cells(DIST_COL).Value = distance
                Set destRw = destRw.Offset(1, 0)
            End If
        Next j
    Next i

    With wsComp 'Formatting "CompSheet" Data
        .Columns.AutoFit
        .Range("AO:AO").NumberFormat = "#,##0.0"
        .UsedRange.Font.Bold = False
        .Cells(1, 1).EntireRow.Font.Bold = True
    End With
End Sub

'Miles between (latA,lonA) and (latB,lonB)
Function DistanceCalc(latA As Double, lonA As Double, latB As Double, lonB As Double) As Double
    Const RAD_MULT As Double = 1.74532925199433E-02
    Dim dlon As Double, x As Double, y As Double
    latA = latA * RAD_MULT
    latB = latB * RAD_MULT
    dlon = RAD_MULT * (lonB - lonA)
    x = Sin(latA) * Sin(latB) + Cos(latA) * Cos(latB) * Cos(dlon)
    y = Sqr((Cos(latB) * Sin(dlon)) ^ 2 + (Cos(latA) * Sin(latB) - Sin(latA) * Cos(latB) * Cos(dlon)) ^ 2)
    'DistanceCalc = WorksheetFunction.Atan2(x, y) * 3963.19
    DistanceCalc = ArcTan2(x, y) * 3963.19 'VBA version is faster
End Function

'VBA version of WorksheetFunction.Atan2
Function ArcTan2(x As Double, y As Double) As Double
    Const PI As Double = 3.14159265358979
    Const PI_2 As Double = 1.5707963267949
    Select Case x
        Case Is > 0
            ArcTan2 = Atn(y / x)
        Case Is < 0
            ArcTan2 = Atn(y / x) + PI * Sgn(y)
            If y = 0 Then ArcTan2 = ArcTan2 + PI
        Case Is = 0
            ArcTan2 = PI_2 * Sgn(y)
    End Select
End Function

Answer 3

应少于 10 秒

Option Explicit

Sub CompareColumns()

    'change these variable to switch the column that is being compared
    Const compareLat = 38 'AL
    Const compareLon = 39 'AM
    Const compareLatArray = 38 'AL
    Const compareLonArray = 39 'AM
    
    Const distance_toggle = 1.5
    
    Dim wb As Workbook
    Dim wsClosed As Worksheet, wsActive As Worksheet, wsComp As Worksheet
    Dim n As Long, rComp As Long, colsClosed As Long, t0 As Single: t0 = Timer
    
    Set wb = ThisWorkbook
    With wb
        Set wsActive = .Sheets("Active")
        Set wsClosed = .Sheets("Closed")
        
        n = .Sheets.Count
        On Error Resume Next
        Set wsComp = .Sheets("CompSheet")
        On Error GoTo 0

        If wsComp Is Nothing Then
    
            Set wsComp = .Sheets.Add(After:=.Sheets(n))
            With wsComp
                .Name = "CompSheet"
                'copy the header row from the "Closed" worksheet
                'when it first creates the "CompSheet" worksheet
                wsClosed.Rows(1).Copy .Range("A1")

                'Add the column header "uniqueID" and "CompDistance"
                'to the end of row 1 of the "CompSheet" worksheet
                colsClosed = .UsedRange.Columns.Count
                .Cells(1, colsClosed + 1).Value = "uniqueID"
                .Cells(1, colsClosed + 2).Value = "CompDistance"
                
                'Formatting "CompSheet" Data
                .Columns.AutoFit
                .Range("AO:AO").NumberFormat = "#,##0.0"
                .UsedRange.Font.Bold = False
                .Cells(1, 1).EntireRow.Font.Bold = True
             End With
        Else
             colsClosed = wsClosed.UsedRange.Columns.Count
        End If
        rComp = wsComp.UsedRange.Rows.Count + 1
    End With
    
    'Store the data from the "Active" and "Closed"
    'worksheet into the array
    Dim arActive, arClosed
    arActive = wsActive.UsedRange.Value
    arClosed = wsClosed.UsedRange.Value
        
    Dim i As Long, j As Long,  k As Long
    Dim lat_a As Double, lon_a As Double, lat_c As Double, lon_c As Double
    Dim x As Double, y As Double, dLon As Double, distance As Double
    Dim uniqueID As String
    
    'Calculationg for D2R = 0.0174532925199433
    'pi = 4 * Atn(1)
    'D2R = pi / 180#
    Const FACTOR As Double = 1.74532925199433E-02
    
    ' dimension max possible rows
    Dim arComp, z As Long
    z = UBound(arActive) * UBound(arClosed)
    ReDim arComp(1 To z, 1 To colsClosed + 2)
    rComp = 0
    
    'Loop through all the rows in the "Active" worksheet starting on row 2
    For i = 2 To UBound(arActive, 1)
    
        lat_a = arActive(i, compareLat) * FACTOR
        lon_a = arActive(i, compareLon)

        'Loop through the array to look up the data in the "Closed" worksheet
        For j = 2 To UBound(arClosed, 1)
        
            lat_c = arClosed(j, compareLatArray) * FACTOR
            lon_c = arClosed(j, compareLonArray)
            dLon = FACTOR * (lon_c - lon_a)
    
            x = Sin(lat_a) * Sin(lat_c) + Cos(lat_a) * Cos(lat_c) * Cos(dLon)
            y = Sqr((Cos(lat_c) * Sin(dLon)) ^ 2 + (Cos(lat_a) * Sin(lat_c) - Sin(lat_a) * Cos(lat_c) * Cos(dLon)) ^ 2)
    
            distance = WorksheetFunction.Atan2(x, y) * 3963.19
    
            If distance <= distance_toggle Then
                    
                'Create a uniqueID by combining column 6 from
                'both the Active and Closed worksheets
                'with a space and "&" in between
                uniqueID = arActive(i, 5) & " " & "&" & " " & arClosed(j, 5)
                
                'Copy the row from the Closed worksheet to the
                'CompSheet worksheet in the next available row
                'Paste the uniqueID and distance in the next available column
                'of the new row in the CompSheet worksheet
                rComp = rComp + 1
                For k = 1 To colsClosed
                    arComp(rComp, k) = arClosed(j, k)               
                Next
                arComp(rComp, k) = uniqueID
                arComp(rComp, k + 1) = distance
                
            End If
        Next j
    Next i
    
    'Turn off screen updating and automatic calculation
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    ' result
    Dim rngComp As Range
    With wsComp
        Set rngComp = .Cells(.UsedRange.Rows.Count + 1, "A")
        Set rngComp = rngComp.Resize(rComp, colsClosed + 2)
        rngComp = arComp
    End With

    'Turn on screen updating and automatic calculation
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Data written " & rngComp.Address, vbInformation, "Took " & Format(Timer - t0, "0.00 secs")
    
End Sub

Answer 4

您可以执行一些基本操作来加快代码速度。 最简单的是禁用屏幕更新和计算。 您可以使用错误处理来确保重新启用它们。

Sub MyFasterProcess()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    On Error GoTo Finally
    Call MyLongRunningProcess()

Finally:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    If Err > 0 Then Err.Raise Err
End Sub

有些人喜欢把它放到一些辅助函数中，甚至是一个 class 来管理 state 多个进程。

长时间运行进程的最常见罪魁祸首是读取和写入单元格。 读取数组比读取范围内的单个单元格要快得多。

考虑以下：

Sub SlowReadWrite()
    Dim src As Range
    Set src = Range("A1:AA100000")

    Dim c As Range
    For Each c In src
        c.Value = c.Value + 1
    Next c
End Sub

这将需要非常非常长的时间。 现在让我们用一个数组来做。 读一遍。 写一次。 无需禁用屏幕更新或将计算设置为手动。 这将与他们一样快。

Sub FastReadWrite()
    Dim src As Range
    Set src = Range("A1:AA100000")

    'Read once.
    Dim vals() As Variant
    vals = r.Value

    Dim r As Long, c As Long
    For r = 1 To UBound(vals, 1)
        For c = 1 To UBound(vals, 2)
            vals(r, c) = vals(r, c) + 1
        Next c
    Next r

    'Write once.
    src.Value = vals
End Sub

您的代码看起来仍在循环中执行读/写操作，这会减慢您的速度。