Excel VBA代码在Source File数据变更后无响应问题求助

问题背景 #

原本可处理50万行数据的VBA代码，在Source File数据变更后，仅35万行就出现无响应。代码功能为从Source File中按匹配值提取整行数据，粘贴至Destination File的Sheet2中，推测核心原因是搜索与写入环节的性能瓶颈。

原代码 #

Sub FMID()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Dim wb1 As Workbook
    Dim wsHF As Worksheet
    Dim wsWellcare As Worksheet
    Dim searchValue As Variant
    Dim lastRow As Long
    Dim source1Data As Variant
    Dim source2Data As Variant
    Dim targetRow As Long
    
    Set wb1 = Workbooks("Source File.xlsx")
    Set wsHF = ThisWorkbook.Worksheets("Sheet1")
    Set wsWellcare = ThisWorkbook.Worksheets("Sheet2")
    
    Dim lastRow2 As Long
    lastRow2 = wsWellcare.Cells(wsWellcare.Rows.Count, "A").End(xlUp).Row
    If lastRow2 > 1 Then
        wsWellcare.Range("A2:A" & lastRow2).EntireRow.Delete
    End If
    
    lastRow = wsHF.Cells(wsHF.Rows.Count, "C").End(xlUp).Row
    source1Data = wb1.Worksheets("Sheet1").UsedRange.Value

    Dim searchDictionary As Object
    Set searchDictionary = CreateObject("Scripting.Dictionary")
    
    ' Populate the dictionary with source data
    PopulateDictionary source1Data, searchDictionary
    
    For targetRow = 2 To lastRow
        searchValue = wsHF.Cells(targetRow, "C").Value
        
        If searchValue <> "" And searchDictionary.Exists(searchValue) Then
            Dim rowNumbers As Collection
            Set rowNumbers = searchDictionary(searchValue)
            
            Dim i As Variant
            For Each i In rowNumbers
                Dim sourceRow As Long
                sourceRow = i ' The row number in the source data
                Dim targetRowWellcare As Long
                targetRowWellcare = wsWellcare.Cells(wsWellcare.Rows.Count, "C").End(xlUp).Row + 1
                
                ' Copy the data from source1Data to wsWellcare
                Dim sourceDataColumns As Long
                sourceDataColumns = UBound(source1Data, 2)
                
                Dim columnOffset As Long
                columnOffset = 0 ' Adjust this based on the target column you want to copy to
                
                wsWellcare.Cells(targetRowWellcare, "A").Resize(1, sourceDataColumns).Value = _
                    Application.Index(source1Data, sourceRow, 0)
                
            Next i
        End If
    Next targetRow
    MsgBox "DATA HAS BEEN COPIED SUCCESSFULLY"
    wsWellcare.Activate
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

Sub PopulateDictionary(sourceData As Variant, ByRef dictionary As Object)
    Dim i As Long
    For i = LBound(sourceData, 1) To UBound(sourceData, 1)
        Dim searchValue As Variant
        searchValue = sourceData(i, 3)
        If Not IsEmpty(searchValue) Then
            If Not dictionary.Exists(searchValue) Then
                Set dictionary(searchValue) = New Collection
            End If
            dictionary(searchValue).Add i
        End If
    Next i
End Sub

卡顿核心原因 #

1. 逐行写入工作表：循环中每次匹配到数据就执行单行写入，频繁触发工作表IO操作，累积大量耗时。
2. 重复计算目标行位置：每次写入前都调用End(xlUp)获取目标行，重复访问工作表增加不必要的开销。
3. Application.Index循环调用：该函数单次调用开销虽小，但数万次循环后会成为显著性能瓶颈。

优化后的代码 #

Sub FMID_Optimized()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Dim wb1 As Workbook
    Dim wsHF As Worksheet
    Dim wsWellcare As Worksheet
    Dim searchValue As Variant
    Dim lastRow As Long
    Dim source1Data As Variant
    Dim resultData As Variant
    Dim targetRow As Long, resultRow As Long
    Dim colCount As Long
    
    Set wb1 = Workbooks("Source File.xlsx")
    Set wsHF = ThisWorkbook.Worksheets("Sheet1")
    Set wsWellcare = ThisWorkbook.Worksheets("Sheet2")
    
    ' 清空目标表旧数据
    Dim lastRow2 As Long
    lastRow2 = wsWellcare.Cells(wsWellcare.Rows.Count, "A").End(xlUp).Row
    If lastRow2 > 1 Then
        wsWellcare.Range("A2:A" & lastRow2).EntireRow.Delete
    End If
    
    ' 加载源数据和搜索列到内存数组
    lastRow = wsHF.Cells(wsHF.Rows.Count, "C").End(xlUp).Row
    source1Data = wb1.Worksheets("Sheet1").UsedRange.Value
    colCount = UBound(source1Data, 2)
    
    ' 构建字典：直接存储匹配值对应的整行数据
    Dim searchDict As Object
    Set searchDict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = LBound(source1Data, 1) To UBound(source1Data, 1)
        searchValue = source1Data(i, 3)
        If Not IsEmpty(searchValue) Then
            If Not searchDict.Exists(searchValue) Then
                searchDict(searchValue) = New Collection
            End If
            searchDict(searchValue).Add Application.Index(source1Data, i, 0)
        End If
    Next i
    
    ' 预估总匹配行数，初始化结果数组
    Dim totalMatches As Long
    totalMatches = 0
    For targetRow = 2 To lastRow
        searchValue = wsHF.Cells(targetRow, "C").Value
        If searchDict.Exists(searchValue) Then
            totalMatches = totalMatches + searchDict(searchValue).Count
        End If
    Next targetRow
    
    If totalMatches > 0 Then
        ReDim resultData(1 To totalMatches, 1 To colCount)
        resultRow = 0
        
        ' 填充结果数组
        For targetRow = 2 To lastRow
            searchValue = wsHF.Cells(targetRow, "C").Value
            If searchDict.Exists(searchValue) Then
                Dim matchItem As Variant
                For Each matchItem In searchDict(searchValue)
                    resultRow = resultRow + 1
                    For i = 1 To colCount
                        resultData(resultRow, i) = matchItem(i)
                    Next i
                Next matchItem
            End If
        Next targetRow
        
        ' 一次性写入工作表，大幅减少IO操作
        wsWellcare.Cells(2, "A").Resize(totalMatches, colCount).Value = resultData
    End If
    
    MsgBox "DATA HAS BEEN COPIED SUCCESSFULLY"
    wsWellcare.Activate
    
    ' 恢复Excel环境
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

优化点说明 #

• 批量写入工作表：先将所有匹配数据存入内存数组，最后一次性写入目标表，把多次IO操作缩减为1次。
• 预存储匹配行数据：构建字典时直接保存整行数据，避免后续重复调用Application.Index。
• 减少工作表访问：仅在初始化时读取搜索列数据，循环中不再频繁访问工作表单元格。
• 预估数组大小：提前计算总匹配行数，初始化固定大小的结果数组，避免动态扩容的额外开销。

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