当源文件数据更改时，Excel VBA 代码停止工作

Question

我已经成功使用以下代码几天了，但是当Source File. 现在，代码使文件Not Responding.The Source Fileused 包含大约 500K 行，并且运行良好。然而，现在即使有 350K 行，它也陷入困境。

该代码的目的是从不同的工作簿中提取数据，根据匹配值复制整行，然后将它们粘贴到Destination FileSheet2 中。

我怀疑速度减慢是由于搜索所需的时间造成的，从而导致了Not Responding问题。

任何帮助或见解将不胜感激。谢谢。”

我提供了一个包含这两个文件的链接，这应该可以让您更清楚地了解该问题。文件

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

Answer 1

Application.Index使用“切片”数组来获取单行似乎很方便，但事实是它确实很慢，因此如果您希望代码尽快运行，则应该不惜一切代价避免它。最好在 VBA 中编写一个小函数来挑选行。

下面举例说明了它的速度有多慢，特别是当您的源数组很大时：

Sub Tester()
    Const NUM_ROWS As Long = 200000
    Dim source1Data, i As Long, t As Double, n As Long
    
    With ActiveSheet.Range("A1:J11").Resize(NUM_ROWS)
        .Value = "blah"
        source1Data = .Value
    End With
    
    Debug.Print "# of source rows:", NUM_ROWS
    
    Application.ScreenUpdating = False
    t = Timer
    For i = 1 To 20
        n = 1 + CLng(Rnd() * (NUM_ROWS - 2))
        ActiveSheet.Range("L1").Resize(1, 10).Value = Application.Index(source1Data, n, 0)
    Next i
    Debug.Print "Index", Timer - t
    
    t = Timer
    For i = 1 To 20
        n = 1 + CLng(Rnd() * (NUM_ROWS - 2))
        ActiveSheet.Range("L1").Resize(1, 10).Value = SliceRow(source1Data, n)
    Next i
    Debug.Print "SliceRow", Timer - t
    
    Application.ScreenUpdating = True
    
End Sub

Function SliceRow(arr, rownum As Long)
    Dim rw(), c As Long
    ReDim rw(1 To 1, 1 To UBound(arr, 2))
    For c = LBound(arr, 2) To UBound(arr, 2)
        rw(1, c) = arr(rownum, c)
    Next c
    SliceRow = rw
End Function

请注意，我们只挑选了20 行- 这是输出：

# of source rows:  350000 
Index              12.775390625   '<<< yikes!
SliceRow           0.001953125    '<<< much better...

我认为速度缓慢Index是因为工作表函数经过优化以处理工作表上的数据，而不是 VBA 数组中的数据，因此首先需要将数组重新处理为Index可以处理的格式，而您正在这样做每次调用 时都会生成一个 350k 行数组Index。VBA 替代方案仅按原样引用数组，因此速度更快。随着数组大小的增加，两种方法之间的性能差异变得更大。

回到实际的用例...
在测试中，这对我来说相当快（<2秒）：添加了一些匹配行的批处理以限制写入工作表的数量。

# of source rows:  350000 
Index              12.775390625   '<<< yikes!
SliceRow           0.001953125    '<<< much better...