基于城市列表处理数据的VBA代码提速优化求助

原代码的性能瓶颈 #

• 嵌套循环冗余：遍历271个城市时，每个城市都要完整扫描一遍源数据，数据量大时重复计算量呈指数级增长。
• 逐单元格读写：每次单个单元格的赋值操作都会触发Excel的工作表交互，这是VBA中最影响性能的操作之一。
• 行跳过逻辑不严谨：i = i + 1的判断可能误跳过有效数据，同时额外增加了循环内的判断开销。

优化后的代码 #

Sub CopyDataByCity_Optimized()
    Dim sourceSheet As Worksheet, targetSheet As Worksheet, citySheet As Worksheet
    Dim sourceData As Variant, cityList As Variant, resultArr() As Variant
    Dim cityDict As Object
    Dim lastRow As Long, i As Long, j As Long, resultRow As Long
    Dim colMap As Variant ' 源列到目标列的映射：(源列号, 目标列号)
    
    ' 初始化工作表对象
    Set sourceSheet = ThisWorkbook.Sheets("Portfolio Summary")
    Set targetSheet = ThisWorkbook.Sheets("RAW DATA")
    Set citySheet = ThisWorkbook.Sheets("City List")
    Set cityDict = CreateObject("Scripting.Dictionary")
    
    ' 禁用Excel功能以提升速度
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    ' 1. 读取城市列表到数组，并存入字典（用于快速判断）
    cityList = citySheet.Range("A1:A271").Value
    For i = 1 To UBound(cityList)
        If Not cityDict.Exists(cityList(i, 1)) Then
            cityDict(cityList(i, 1)) = True ' 标记需要筛选的城市
        End If
    Next i
    
    ' 2. 读取源数据到数组（从第8行开始，包含需要的列）
    lastRow = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row
    ' 定义源列与目标列的映射：(源列号, 目标列号)，最后一列是固定写入城市名的目标列I(9)
    colMap = Array( _
        Array(3, 1), Array(8, 2), Array(4, 3), Array(19, 4), _
        Array(9, 5), Array(18, 6), Array(23, 7), Array(14, 8), Array(0, 9) _
    )
    ' 读取源数据的所有行（从第8行到lastRow）和需要的列（C,H,D,S,I,R,W,N,Q）
    sourceData = sourceSheet.Range("A8:W" & lastRow).Value
    
    ' 3. 预分配结果数组大小（最多为源数据行数，列数为9）
    ReDim resultArr(1 To UBound(sourceData, 1), 1 To UBound(colMap) + 1)
    resultRow = 0
    
    ' 4. 遍历源数据，筛选符合条件的行
    For i = 1 To UBound(sourceData, 1)
        Dim currentCity As String
        currentCity = sourceData(i, 17) ' 源数据中Q列是第17列（A是第1列）
        
        ' 判断当前城市是否在筛选列表中
        If cityDict.Exists(currentCity) Then
            resultRow = resultRow + 1
            ' 按映射复制列数据
            For j = 0 To UBound(colMap) - 1
                resultArr(resultRow, colMap(j)(2)) = sourceData(i, colMap(j)(1))
            Next j
            ' 写入城市名到目标列I
            resultArr(resultRow, 9) = currentCity
        End If
    Next i
    
    ' 5. 清空目标表原有数据（从第2行开始），并写入结果数组
    With targetSheet
        .Range("A2:I" & .Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
        If resultRow > 0 Then
            .Range("A2:I" & resultRow + 1).Value = resultArr
        End If
    End With
    
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    MsgBox "数据筛选复制完成！共处理 " & resultRow & " 行数据。"
End Sub

关键优化点说明 #

1. 批量读写数组：将源数据、城市列表全部读入内存数组，最后一次性写入结果，彻底避免逐单元格交互，这是性能提升最显著的点。
2. 字典快速判断：用字典存储需要筛选的城市，判断城市是否在列表中的时间复杂度从O(n)降到O(1)。
3. 取消嵌套循环：只遍历一次源数据即可完成所有筛选，时间复杂度从O(m*n)降至O(m+n)（m为源数据行数，n为城市数）。
4. 禁用Excel后台功能：关闭屏幕更新、事件和自动计算，减少运行时的资源占用。
5. 列映射配置化：用数组定义源列到目标列的对应关系，后续修改列映射只需调整数组，无需修改循环逻辑。

内容的提问来源于stack exchange，提问作者dhanesh sharma