加速循环/匹配 - 代码运行速度很慢

Question

我的代码将 Sheet1 上 C 列中的单元格值与 Sheet3 上的数据透视表相匹配，然后复制某些列。

• 代码将检查 Sheet1 上有多少条目需要检查
• 循环 2：对于 C/Sheet1 列中的每个值与工作表 2 上 A 列中的匹配项，它将复制 B、C、D、E 列中的相应数据。
• 由于值/表可能有多个匹配项，因此我将数据提取限制为三个匹配项（代码中的三个循环）。为了实现这一点，我正在增加 i +1 或 i+2 以获取数据透视表中的下一行。

Sheet 2 上的表格有时超过 10,000 行，Excel 崩溃。

有没有人知道如何加快循环代码（Loop2,3,4 相同）以减少工作强度，例如阵列可能？它们导致锁定，因为我认为代码一直在 A 列上下运行。

  Set sheet3 = Sheets("OrbitPivotTable")
  CellChanged = Sheet1.Range("A1").Value + 1

  LastRow = sheet3.Cells(Rows.Count, "A").End(xlUp).Row
  LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
'Loop1
    
  For i = 1 To LastRow

   If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep2
      
      If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
         Sheet1.Range("H" & CellChanged).Value = sheet3.Range("B" & i).Value 'Customer
         Sheet1.Range("I" & CellChanged).Value = sheet3.Range("C" & i).Value 'Rate Val start
         Sheet1.Range("J" & CellChanged).Value = sheet3.Range("D" & i).Value 'ATA All in
         Sheet1.Range("K" & CellChanged).Value = sheet3.Range("E" & i).Value 'Special Remarks

          Found = True
        End If
         If Found = True Or i = LastRow Then
            If CellChanged = LastData Then
                Exit For
            End If
            If Found = True Then
                Found = False
Nextstep2:
                CellChanged = CellChanged + 1
            End If
            i = 0
        End If
    Next i
    
'Loop2

等等……

Excel File

Answer 1

我可能误解了您共享文件中的过程，但这应该更快（并且总体上代码更少）。

我将数据透视表查找置于循环中，切换到Match()，并尽可能减少使用数组的读/写次数。

EDITED 修复了一个令人尴尬的错误，我忘记调整 Match() 结果 m 以说明我针对运行 match() 的范围的起始行...

Sub HB_IPT_Rate_Check()

    Dim wsReport As Worksheet, wsCPK As Worksheet, wsOrbitPivot As Worksheet
    Dim c As Range, rwReport As Range, lastPivotRow As Long
    Dim ata, m, numMatches As Long, matchFrom As Long, matchRow As Long
    
    Set wsReport = ThisWorkbook.Worksheets("Comparison Report")
    Set wsCPK = ThisWorkbook.Worksheets("CPK")
    Set wsOrbitPivot = ThisWorkbook.Worksheets("OrbitPivotTable")
    
    'loop over the rows in the report sheet
    For Each c In wsReport.Range("C3", wsReport.Cells(Rows.Count, "C").End(xlUp)).Cells
        
        ata = c.Value 'read this once....
        Set rwReport = c.EntireRow
        
        '1st Database Match "CPK"
        m = Application.Match(ata, wsCPK.Columns("A"), 0)
        If Not IsError(m) Then
            With wsCPK.Rows(m)
                rwReport.Columns("D").Resize(1, 4).Value = _
                   Array(.Columns("B").Value, .Columns("C").Value, _
                         .Columns("F").Value, .Columns("H").Value)
                'Sum of HB CWGT (KG),Sum of MB CWGT (KG),Achiev CPK,Density
            End With
        Else
            'no match...
        End If
        
        '2nd Database Match "Orbit"
        lastPivotRow = wsOrbitPivot.Cells(Rows.Count, "A").End(xlUp).Row
        numMatches = 0  'reset match count
        matchFrom = 2
        m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
        'keep going while we still have a match and we've not reached the max result count
        Do While Not IsError(m) And numMatches < 3
            numMatches = numMatches + 1
            matchRow = matchFrom + (m - 1) 'adjust the matched row index according to where we started looking...
            
            'sanity check
            Debug.Print "Matched " & ata & " on row " & matchRow
            
            rwReport.Columns("H").Offset(0, (numMatches - 1) * 4).Resize(1, 4).Value = _
                                    wsOrbitPivot.Cells(matchRow, "B").Resize(1, 4).Value
            
            'find the next match if any, starting below the last match
            matchFrom = matchRow + 1
            m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
        Loop
    Next c 'next report row
    
  
End Sub

Answer 2

1. 使用字典设置行号和列号。

2. 分配数据以适应虚拟数组中的行和列。

---

Sub test()
    Dim Ws(1 To 4) As Worksheet
    Dim DicR As Object  ' Dictionary
    Dim DicC As Object  ' Dictionary
    Dim vDB, arr()
    Dim s As String
    Dim i As Long, n As Long, j As Integer
    Dim r As Long, c As Integer
    
    Set Ws(1) = Sheets("Comparison Report")
    Set Ws(2) = Sheets("CPK")
    Set Ws(3) = Sheets("OrbitPivotTable")
    Set Ws(4) = Sheets("Orbit")
    
    'Row index dictionary
    Set DicR = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
    'Column index dictionary
    Set DicC = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary
    
    vDB = Ws(1).UsedRange
    
    For i = 3 To UBound(vDB, 1)
        s = vDB(i, 3)
        If s <> "" Then
            If DicR.Exists(s) Then
               'DicC(s) = DicC(s) + 1
            Else
                n = n + 1
                DicR.Add s, n 'row index
                DicC.Add s, 0 'column index
            End If
        End If
    Next i
    
    'Create an array of virtual tables based on the number of dictionaries.
    'Since the number of columns cannot be predicted, a specific number of 1000 was entered.
    'in my test, number 100 is too small
    ReDim arr(1 To DicR.Count, 1 To 1000)
    
    For j = 2 To 4
        vDB = Ws(j).Range("a1").CurrentRegion
        For i = 2 To UBound(vDB, 1)
            s = vDB(i, 1)
            If DicR.Exists(s) Then
                r = DicR(s)
                c = DicC(s) * 4 + 1
                DicC(s) = DicC(s) + 1
                arr(r, c) = vDB(i, 2)
                arr(r, c + 1) = vDB(i, 3)
                arr(r, c + 2) = vDB(i, 4)
                arr(r, c + 3) = vDB(i, 5)
            End If
        Next i
    Next j
    With Ws(1)
        .Range("d3").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
    End With
End Sub

结果图片