Arrays 加速循环/匹配-代码运行非常慢

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

代码将检查表1上有多少条目需要检查 循环2：对于第2页a列中匹配的C/Sheet1列中的每个值，它将复制B、C、D、E列中的相应数据。 由于值/表可能有多个匹配，我将数据拉取限制为三个匹配，代码中有三个循环。为了实现这一点，我增加了I+1或I+2以获得透视表中的下一行。 工作表2中的表格有时超过10000行，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

等等

---

我可能误解了您共享的文件中的过程，但总体而言，这应该更快，代码更少

我将pivot表查找放在一个循环中，切换为匹配，并尽可能使用数组减少读/写次数

编辑修复了一个令人尴尬的错误，我忘了调整匹配结果m，以说明我运行匹配所针对的范围的起始行

次级HB_IPT_费率检查 将wsReport设置为工作表、将wsCPK设置为工作表、将wsCPK设置为工作表 尺寸c作为范围，rwReport作为范围，lastPivotRow作为长度 Dim ata、m、numMatches等长、matchFrom等长、matchRow等长 设置wsReport=ThisWorkbook.WorksheetComparison报告 设置wsCPK=ThisWorkbook.WorksheetsCPK 设置wsOrbitPivot=ThisWorkbook.WorksheetsOrbitPivotTable '在报告表中的行上循环 对于wsReport.RangeC3、wsReport.CellsRows.Count、c.EndxlUp.Cells中的每个c ata=c.值“读取此值一次…”。。。。 设置rwReport=c.EntireRow '第一个数据库匹配CPK m=Application.Matchata，wsCPK.ColumnsA，0 如果不是伊瑟罗，那么 使用wsCPK.Rowsm rwReport.ColumnsD.Resize1，4.值=_ Array.ColumnsB.Value、.ColumnsC.Value、_ .ColumnsF.Value、.ColumnsH.Value ‘HB CWGT KG之和，MB CWGT KG之和，实现CPK，密度 以 其他的 “没有对手。。。 如果结束 '第二个数据库匹配轨道 lastPivotRow=wsOrbitPivot.CellsRows.Count，A.EndxlUp.Row numMatches=0'重置匹配计数 matchFrom=2 m=Application.Matchata，wsOrbitPivot.RangeA&matchFrom&:A&lastPivotRow，0 “继续前进，我们还有一场比赛，但我们还没有达到最高结果计数。” 不要在iSeries和numMatches<3的情况下执行此操作 numMatches=numMatches+1 matchRow=matchFrom+m-1'根据我们开始查找的位置调整匹配的行索引。。。 “精神检查 调试。打印匹配的数据行和匹配行（&A） rwReport.ColumnsH.Offset0，numMatches-1*4.Resize1，4.值=_ wsOrbitPivot.cellsMachrow，B.Resize1，4.Value '查找下一个匹配项（如果有），从上一个匹配项下方开始 matchFrom=matchRow+1 m=Application.Matchata，wsOrbitPivot.RangeA&matchFrom&:A&lastPivotRow，0 环 下一个c'下一个报告行 端接头

---

我可能误解了您共享的文件中的过程，但总体而言，这应该更快，代码更少

我将pivot表查找放在一个循环中，切换为匹配，并尽可能使用数组减少读/写次数

编辑修复了一个令人尴尬的错误，我忘了调整匹配结果m，以说明我运行匹配所针对的范围的起始行

次级HB_IPT_费率检查 将wsReport设置为工作表、将wsCPK设置为工作表、将wsCPK设置为工作表 尺寸c作为范围，rwReport作为范围，lastPivotRow作为长度 Dim ata、m、numMatches等长、matchFrom等长、matchRow等长 设置wsReport=ThisWorkbook.WorksheetComparison报告 设置wsCPK=ThisWorkbook.WorksheetsCPK 设置wsOrbitPivot=ThisWorkbook.WorksheetsOrbitPivotTable '在报告表中的行上循环 对于wsReport.RangeC3、wsReport.CellsRows.Count、c.EndxlUp.Cells中的每个c ata=c.值“读取此值一次…”。。。。 设置rwReport=c.EntireRow '第一个数据库匹配CPK m=Application.Matchata，wsCPK.ColumnsA，0 如果不是伊瑟罗，那么 使用wsCPK.Rowsm rwReport.ColumnsD.Resize1，4.值=_ Array.ColumnsB.Value、.ColumnsC.Value、_ .ColumnsF.Value、.ColumnsH.Value ‘HB CWGT KG之和，MB CWGT KG之和，实现CPK，密度 以 其他的 “没有对手 ... 如果结束 '第二个数据库匹配轨道 lastPivotRow=wsOrbitPivot.CellsRows.Count，A.EndxlUp.Row numMatches=0'重置匹配计数 matchFrom=2 m=Application.Matchata，wsOrbitPivot.RangeA&matchFrom&:A&lastPivotRow，0 “继续前进，我们还有一场比赛，但我们还没有达到最高结果计数。” 不要在iSeries和numMatches<3的情况下执行此操作 numMatches=numMatches+1 matchRow=matchFrom+m-1'根据我们开始查找的位置调整匹配的行索引。。。 “精神检查 调试。打印匹配的数据行和匹配行（&A） rwReport.ColumnsH.Offset0，numMatches-1*4.Resize1，4.值=_ wsOrbitPivot.cellsMachrow，B.Resize1，4.Value '查找下一个匹配项（如果有），从上一个匹配项下方开始 matchFrom=matchRow+1 m=Application.Matchata，wsOrbitPivot.RangeA&matchFrom&:A&lastPivotRow，0 环 下一个c'下一个报告行 端接头 使用字典设置行数和列数

为虚拟阵列中的行和列分配数据

结果图像 使用字典设置行数和列数

为虚拟阵列中的行和列分配数据

结果图像

---

如果使用Application.Match在每张工作表上查找匹配项，它将比循环更快。我会避免使用工作表变量名，如Sheet1等，因为它们与Excel指定的默认工作表代码名匹配-这没有错，但可能会让人混淆。最好使用与实际工作表用途相对应的变量名—wsComp、wsCPK等。仅供参考，如果发布的代码较少，则更可能得到响应。这是一个很大的过程。好的，谢谢你的反馈。我在其他帖子上看到没有发布足够的代码。让我缩小上面的请求，然后尝试application.match。@TimWilliams我需要将所有sheet1.range车道转换为application.match还是仅转换为比赛所在环路中的第一条车道？将代码更改为：如果Application.MatchSheet1.RangeC&CellChanged.Value，Sheet2.RangeA&i，0，那么我是否需要保留.Range？您是否有机会共享工作簿或至少一些屏幕截图？我在计算您的确切过程时遇到问题-例如，通常在循环中修改For循环计数器不是一个好主意，因此设置'I=0'很奇怪。如果这是您想要做的，您可以使用Exit For退出循环。如果找到匹配项，则i=0'。检查将在第1行再次开始，并继续，直到找到下一个匹配项。如果使用Application.Match在每张工作表上查找匹配项，它将比循环更快。我会避免使用工作表变量名，如Sheet1等，因为它们与Excel指定的默认工作表代码名匹配-这没有错，但可能会让人混淆。最好使用与实际工作表用途相对应的变量名—wsComp、wsCPK等。仅供参考，如果发布的代码较少，则更可能得到响应。这是一个很大的过程。好的，谢谢你的反馈。我在其他帖子上看到没有发布足够的代码。让我缩小上面的请求，然后尝试application.match。@TimWilliams我需要将所有sheet1.range车道转换为application.match还是仅转换为比赛所在环路中的第一条车道？将代码更改为：如果Application.MatchSheet1.RangeC&CellChanged.Value，Sheet2.RangeA&i，0，那么我是否需要保留.Range？您是否有机会共享工作簿或至少一些屏幕截图？我在计算您的确切过程时遇到问题-例如，通常在循环中修改For循环计数器不是一个好主意，因此设置'I=0'很奇怪。如果这是您想要做的，您可以使用Exit For退出循环。如果找到匹配项，则i=0'。检查将在第1行再次开始，并继续，直到找到下一个匹配项。好像加倍努力了谢谢。李小姐，你的选择也行。谢谢。李先生，你的选择也行。

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