Excel VBA集合数据处理性能异常问题求助

核心性能瓶颈 #

处理SourceWB的代码耗时过长，根源在于以下几个低效逻辑：

1. 遍历固定超大范围而非实际有效行
   你当前循环BU4:BU10000，即便实际只有2500条非空数据，循环仍会执行9997次，大量空行的判断完全是无用开销。

2. 重复跨工作簿访问对象
   每次循环中多次调用Workbooks("SourceWB").Worksheets("Source2")，跨工作簿的对象访问本身就有性能损耗，重复调用会累积大量无效开销。

3. 逐单元格读取数据
   循环中单独读取单个单元格的值，VBA与Excel单元格的交互是性能密集型操作，频繁调用会显著拖慢速度。

优化后的代码示例 #

Debug.Print "5 -- " & Now

Dim user As String
user = ThisWorkbook.Worksheets("vir").Range("G2").Value

Dim init_as_entries As New Collection
Dim wsSource2 As Worksheet
Set wsSource2 = Workbooks("SourceWB").Worksheets("Source2")

' 获取BU列实际最后一行，避免遍历空行
Dim lastRow As Long
lastRow = wsSource2.Cells(wsSource2.Rows.Count, "BU").End(xlUp).Row
If lastRow < 4 Then lastRow = 4 ' 确保至少从第4行开始

' 批量读取所需列数据到数组，内存中处理更快
Dim dataArr As Variant
dataArr = wsSource2.Range("A4:BU" & lastRow).Value ' 包含A、B、E、F、BU列

Dim rowIdx As Long
For rowIdx = 1 To UBound(dataArr, 1)
    ' BU列对应数组第73列（A=1，依次类推）
    Dim buValue As Variant
    buValue = dataArr(rowIdx, 73)
    
    If Not IsEmpty(buValue) Then
        If CStr(buValue) = CStr(selected_month) Then
            ' F列对应数组第6列
            If CStr(dataArr(rowIdx, 6)) = user Then
                Dim item_1 As Variant, item_2 As Variant, item_3 As Variant
                item_1 = dataArr(rowIdx, 1) ' A列
                item_2 = dataArr(rowIdx, 2) ' B列
                item_3 = dataArr(rowIdx, 5) ' E列
                
                Dim entry As String
                entry = CStr(item_1) & "_" & CStr(item_2) & "_" & CStr(item_3)
                
                ' 可选：如果需要去重，添加存在性检查
                If IsInCollection(init_as_entries, entry) = False Then
                    init_as_entries.Add entry
                End If
            End If
        End If
    End If
Next rowIdx

' 批量写入目标工作表，避免逐单元格写入开销
Dim targetWs As Worksheet
Set targetWs = ThisWorkbook.Worksheets("target")
Dim outputArr As Variant
ReDim outputArr(1 To init_as_entries.Count, 1 To 3)

Dim collIdx As Long
For collIdx = 1 To init_as_entries.Count
    Dim parts() As String
    parts = Split(init_as_entries(collIdx), "_")
    outputArr(collIdx, 1) = parts(0)
    outputArr(collIdx, 2) = parts(1)
    outputArr(collIdx, 3) = parts(2)
Next collIdx

' 一次性写入F:H列
targetWs.Range("F" & starting_row_2).Resize(UBound(outputArr, 1), 3).Value = outputArr
starting_row_2 = starting_row_2 + UBound(outputArr, 1)

Debug.Print "6 -- " & Now

额外注意事项 #

• 修复语法错误：原代码中Workbooks("SourceWB")))多了一个闭合括号，会导致运行错误，需修正。
• 去重检查（可选）：如果SourceWB的数据存在重复条目，添加IsInCollection检查可以避免重复添加到集合中，减少后续写入的冗余操作。

原有加速设置效果有限的原因 #

你添加的ScreenUpdating=False等设置主要优化Excel界面更新和计算，但核心瓶颈是不必要的循环次数和频繁的单元格对象访问，这些设置无法解决根本问题，必须从循环逻辑和数据读取方式入手优化。

内容的提问来源于stack exchange，提问作者Sebastjan Hribar