嵌套数组循环VBA代码运行过慢，求大规模数据集优化方案

你的核心问题是O(n*m)的嵌套循环导致计算量爆炸：100条在售×1000条已售是10万次计算，放大500倍后直接变成2.5亿次——这才是7-8分钟拉长到60小时的根源。以下是针对大规模数据集的分层优化方案：

一、核心优化：把O(n*m)降到O(n+k)（k为匹配范围内的已售数据） #

1. 地理分区（网格索引） #

把已售房源按经纬度划分固定大小的网格（比如每0.01度≈1公里为一个格子），计算在售房源所在网格后，只对比当前网格及相邻8个网格的已售房源，直接砍掉90%以上的无效计算。

代码示例：

Sub GridBasedMatch()
    ' 1. 加载已售数据到数组并按网格分组
    Dim closedArr As Variant
    closedArr = ThisWorkbook.Sheets("Closed").UsedRange.Value
    Dim closedGrid As Scripting.Dictionary
    Set closedGrid = New Scripting.Dictionary
    Dim latStep As Double, lonStep As Double
    latStep = 0.01 ' 纬度步长≈1公里
    ' 经度步长随纬度变化，用已售数据的中位数纬度修正
    Dim medianLat As Double
    medianLat = WorksheetFunction.Median(WorksheetFunction.Index(closedArr, 0, 3)) ' 假设Lat在第3列
    lonStep = 0.01 / Cos(WorksheetFunction.Radians(medianLat))

    Dim i As Long, gridKey As String
    For i = LBound(closedArr, 1) To UBound(closedArr, 1)
        Dim latGrid As Integer, lonGrid As Integer
        latGrid = Int(closedArr(i, 3) / latStep)
        lonGrid = Int(closedArr(i, 4) / lonStep) ' Lon在第4列
        gridKey = latGrid & "," & lonGrid
        If Not closedGrid.Exists(gridKey) Then
            closedGrid(gridKey) = New Collection
        End If
        closedGrid(gridKey).Add closedArr(i, :) ' 存储整行数据
    Next i

    ' 2. 加载在售数据并匹配对应网格的已售房源
    Dim activeArr As Variant
    activeArr = ThisWorkbook.Sheets("Active").UsedRange.Value
    Dim resultArr() As Variant
    ReDim resultArr(1 To UBound(activeArr, 1) * 100, 1 To UBound(activeArr, 2) + UBound(closedArr, 2)) ' 预分配足够空间
    Dim resultRow As Long: resultRow = 0
    Dim j As Long, currLat As Double, currLon As Double
    Dim dgLat As Integer, dgLon As Integer, checkKey As String
    Dim col As Collection, item As Variant, dist As Double

    For j = LBound(activeArr, 1) To UBound(activeArr, 1)
        currLat = activeArr(j, 3)
        currLon = activeArr(j, 4)
        latGrid = Int(currLat / latStep)
        lonGrid = Int(currLon / lonStep)

        ' 遍历当前网格及相邻8个网格
        For dgLat = -1 To 1
            For dgLon = -1 To 1
                checkKey = (latGrid + dgLat) & "," & (lonGrid + dgLon)
                If closedGrid.Exists(checkKey) Then
                    Set col = closedGrid(checkKey)
                    For Each item In col
                        dist = CalculateDistance(currLat, currLon, item(3), item(4))
                        If dist <= 1 Then ' 假设筛选1公里内的房源
                            resultRow = resultRow + 1
                            ' 写入在售+已售数据
                            For k = 1 To UBound(activeArr, 2)
                                resultArr(resultRow, k) = activeArr(j, k)
                            Next k
                            For k = 1 To UBound(closedArr, 2)
                                resultArr(resultRow, UBound(activeArr, 2) + k) = item(k)
                            Next k
                        End If
                    Next item
                End If
            Next dgLon
        Next dgLat
    Next j

    ' 3. 写入结果到CompSheet
    If resultRow > 0 Then
        ThisWorkbook.Sheets("CompSheet").Range("A2").Resize(resultRow, UBound(resultArr, 2)).Value = resultArr
    End If
End Sub

' 距离计算函数（Haversine公式）
Function CalculateDistance(lat1 As Double, lon1 As Double, lat2 As Double, lon2 As Double) As Double
    Const R As Double = 6371 ' 地球半径（公里）
    Dim dLat As Double, dLon As Double, a As Double, c As Double
    dLat = WorksheetFunction.Radians(lat2 - lat1)
    dLon = WorksheetFunction.Radians(lon2 - lon1)
    a = Sin(dLat / 2) ^ 2 + Cos(WorksheetFunction.Radians(lat1)) * Cos(WorksheetFunction.Radians(lat2)) * Sin(dLon / 2) ^ 2
    c = 2 * WorksheetFunction.Atan2(Sqr(a), Sqr(1 - a))
    CalculateDistance = R * c
End Function

2. 改用ADO SQL空间查询 #

利用Excel的OLEDB驱动，把数据导入内存表，用SQL先做粗筛选（经纬度范围）再做精确距离计算——数据库引擎的查询优化远优于VBA循环，能把计算量压缩到极致。

代码示例：

Sub ADOSpatialQuery()
    Dim conn As Object, rs As Object
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    ' 连接当前Excel文件
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    ' SQL语句：先粗筛经纬度范围，再计算精确距离（筛选1公里内）
    Dim sql As String
    sql = "SELECT a.*, c.*, " & _
          "(6371 * ACOS(COS(RADIANS(a.Lat)) * COS(RADIANS(c.Lat)) * COS(RADIANS(c.Lon) - RADIANS(a.Lon)) + SIN(RADIANS(a.Lat)) * SIN(RADIANS(c.Lat)))) AS Distance " & _
          "FROM [Active$] a, [Closed$] c " & _
          "WHERE ABS(a.Lat - c.Lat) <= 0.009 AND ABS(a.Lon - c.Lon) <= 0.009 " & ' 粗筛≈1公里范围
          "AND (6371 * ACOS(COS(RADIANS(a.Lat)) * COS(RADIANS(c.Lat)) * COS(RADIANS(c.Lon) - RADIANS(a.Lon)) + SIN(RADIANS(a.Lat)) * SIN(RADIANS(c.Lat)))) <= 1"

    ' 执行查询并写入结果
    rs.Open sql, conn
    ThisWorkbook.Sheets("CompSheet").Range("A2").CopyFromRecordset rs

    rs.Close: conn.Close
    Set rs = Nothing: Set conn = Nothing
End Sub

二、次核心优化：减少重复计算 #

1. 预计算经纬度弧度值 #

距离计算需要反复把经纬度转弧度，提前把所有经纬度转成弧度存入数组，避免每次循环重复调用Radians函数。

代码示例：

' 预计算已售数据弧度
Dim closedRadArr() As Double
ReDim closedRadArr(1 To UBound(closedArr, 1), 1 To 2)
For i = 1 To UBound(closedArr, 1)
    closedRadArr(i, 1) = WorksheetFunction.Radians(closedArr(i, 3))
    closedRadArr(i, 2) = WorksheetFunction.Radians(closedArr(i, 4))
Next i

' 预计算在售数据弧度
Dim activeRadArr() As Double
ReDim activeRadArr(1 To UBound(activeArr, 1), 1 To 2)
For j = 1 To UBound(activeArr, 1)
    activeRadArr(j, 1) = WorksheetFunction.Radians(activeArr(j, 3))
    activeRadArr(j, 2) = WorksheetFunction.Radians(activeArr(j, 4))
Next j

' 改造距离函数直接用弧度值
Function CalculateDistanceRad(lat1 As Double, lon1 As Double, lat2 As Double, lon2 As Double) As Double
    Const R As Double = 6371
    Dim dLat As Double, dLon As Double, a As Double, c As Double
    dLat = lat2 - lat1
    dLon = lon2 - lon1
    a = Sin(dLat / 2) ^ 2 + Cos(lat1) * Cos(lat2) * Sin(dLon / 2) ^ 2
    c = 2 * WorksheetFunction.Atan2(Sqr(a), Sqr(1 - a))
    CalculateDistanceRad = R * c
End Function

2. 简化距离计算（可选） #

如果不需要高精度（比如误差在5%以内可接受），改用平面距离公式代替Haversine，去掉三角函数调用，速度能提升3-5倍：

Function CalculateFlatDistance(lat1 As Double, lon1 As Double, lat2 As Double, lon2 As Double) As Double
    Const latKmPerDeg As Double = 111.32 ' 每度纬度≈111.32公里
    Dim lonKmPerDeg As Double
    lonKmPerDeg = 111.32 * Cos(WorksheetFunction.Radians((lat1 + lat2) / 2)) ' 经度每度公里数随纬度变化
    CalculateFlatDistance = Sqr(((lat2 - lat1) * latKmPerDeg) ^ 2 + ((lon2 - lon1) * lonKmPerDeg) ^ 2)
End Function

三、细节优化：榨干VBA性能 #

• 禁用更多Excel功能：在代码开头加上：

  Application.EnableEvents = False
  ActiveWindow.View = xlNormalView ' 关闭分页预览
  Application.DisplayAlerts = False
  

  结尾记得恢复：

  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  

• 用整数索引循环代替For Each：VBA中For i = LBound(arr) To UBound(arr)比For Each item In arr快约20%。
• 预分配结果数组：避免循环中动态扩容（ReDim Preserve），提前预估最大需要写入的行数，一次性分配足够空间。
• 改用64位Excel：64位VBA支持更大的内存，数组处理效率比32位高30%以上。

内容的提问来源于stack exchange，提问作者Steve S