应在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

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

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

这看起来像是你在底部添加了一行。你不需要在底部添加行，它们已经在那里了--只需要注解掉它，然后在“copy”语句中添加1，Rows.Count + 1。

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

这个应该更快编译过了但未经测试。

• 使用工作表引用可以使代码更简洁。
• 已将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

你可以做一些基本的事情来加速代码。最简单的是禁用屏幕更新和计算。你可以使用错误处理来确保它们被重新启用。

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

有些人喜欢把它放到一些帮助函数中，甚至放在一个类中来管理多个进程的状态。
长时间运行进程最常见的原因是阅读和写入单元格。读取数组比读取范围内的单个单元格要快得多。
请考虑以下几点：

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

您的代码看起来仍在循环中执行读/写操作，这是导致您的速度变慢的原因。