Excel 优化宏以进行数百万次计算

我在单独的文件上匹配ID，如果匹配发生，源上的行将被检索到另一个文件。我为这两个文件做了一个FOR语句来扫描每一行，源工作簿有27000多行，另一行大约8000行，如果我理解正确的话，在循环结束之前，这是216M+计算。我已经实现了

屏幕更新=False

和

xlCalculationManual

。但我在这里，我已经等了大约30分钟，并没有代码完成的迹象（VBA编辑器和Excel都“没有响应”）

---

在测试文件上，我实现了代码，它几乎立即运行，并获得了肯定的结果。如果您能提示我改进代码的其他方法，我将不胜感激。

首先，我将添加Application.Statusbar值来控制它的运行时间 第二，如果在内部循环中找到值，我将添加一个出口，以防止循环中出现不必要的步骤，如：

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value
    if filaIndiceFuente  mod 50 = 0 then 
      **Application.statusbar = filaIndiceFuente**  
    end if
    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then

        'CELLS GET TO THE OTHER FILE HERE
        **exit for**
        End If
    Next filaIndiceDestino
Next filaIndiceFuente
Application.statusbar = ""

您可以在内部循环中包含状态栏信息

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value

    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        if filaIndiceDestino mod 50 = 0 then 
            **Application.statusbar = filaIndiceFuente & " - " & filaIndiceDestino **  
        end if
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then

        'CELLS GET TO THE OTHER FILE HERE
        **exit for**
        End If
    Next filaIndiceDestino
Next filaIndiceFuente
Application.statusbar = ""

---

我看不出有什么方法可以让比较更快，但也许其他人有更好的想法。将此视为确定花费很长时间的原因的第一步。

通常，当我在一个大型数据集中迭代匹配时，我发现使用a甚至比使用。

find（）

操作或迭代每一行更快

我想试试这样的东西

Dim dict As New Scripting.Dictionary

For filaIndiceFuente = 2 To filaFuenteUltima
    dict.Add CStr(planillaFuente.Range("A" & filaIndiceFuente).Value), filaIndiceFuente '<- this will act as a pointer to the row where your match data is
Next filaIndiceFuente

For filaIndiceDestino = 2 To filaDestinoUltima
    If dict.Exists(CStr(planillaDestino.Range("A" & filaIndiceDestino).Value)) Then
        'CELLS GET TO THE OTHER FILE HERE
    End If
Next filaIndiceDestino

Set dict = Nothing

Dim dict作为新脚本。字典
对于filaIndiceFuente=2至FILAFUNTEULTIMA
dict.Add CStr（planillaFuente.Range（“A”&filaIndiceFuente.Value）），filaIndiceFuente'首先按A列升序排列planillaFuente.Range，然后：

Dim lookupRange As Range
Set lookupRange = planillaDestino.Range("A2:A" & filaDestinoUltima)

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Cells(filaIndiceFuente, "A").Value
    Dim matchRow As Long
    matchRow = Application.WorksheetFunction.Match(criterioFuente, lookupRange, 1)
    If lookupRange.Cells(matchRow, 1).Value = criterioFuente Then
        'CELLS GET TO THE OTHER FILE HERE
        ' If row to move from planillaFuente to planillaDest, then:
        planillaDest.Cells(matchRow + 1, "P").Value = planillaFuente.Cells(filaIndiceFuente, "D").Value

    End If
Next filaIndiceFuente

我可能会更进一步，将数据加载到数组中，然后在数组中循环。由于读取阵列数据时的偏移，指示符号将关闭1。loadscp例程中有一些漏洞，我构建它是为了重用。我猜你不需要状态栏

Dim scpFuente   As scripting.dictionary
Dim arrFuente    As variant 
Dim arrDest       As variant 

Arrfuente = planillaFuente.range(“a2”).resize(filaFuenteUltima-1,1).value
ArrDest = planillaDestino.range(“a2”).resize(filaDestinaUltima-1,1).value

Set scpFuente = loadscp(arrfuente)


For filaIndiceDestino = lbound(arrDest,1) to ubound(arrDest,1) 
    ' filaIndiceDestino = filaIndiceDestino + 1
    If scpFuente.exists(arrdest(filaindicedestino,1)) Then

    'CELLS GET TO THE OTHER FILE HERE

    End If
Next filaIndiceDestino

loadscp函数：

Public Function Loadscp(ByVal varList As Variant, Optional ByVal intCol As Integer = 1, _
Optional ByVal intCols As Integer = 1, Optional ByVal strDelim As String = ".") As Scripting.Dictionary

Dim scpList             As Scripting.Dictionary

Dim arrVals             As Variant

Dim lngLastRow          As Long
Dim lngRow              As Long
Dim intABSCol           As Integer
Dim intColCurr          As Integer
Dim strVal              As String
Dim intRngCol           As Integer

Set Loadscp = New Scripting.Dictionary
Loadscp.CompareMode = vbTextCompare

intABSCol = Abs(intCol)
If IsArray(varList) Then
    arrVals = varList
ElseIf TypeName(varList) = "Range" Then
    intRngCol = varList.Column
    lngLastRow = LastRow(varList.Parent, intCol)

    If lngLastRow > varList.Row Then
        arrVals = varList.Offset(1, intABSCol - 1).Resize(lngLastRow - varList.Row, 1)
    End If
ElseIf TypeName(varList) = "Dictionary" Then
    Set scpList = varList
    ReDim arrVals(1 To scpList.Count, 1 To 1)
    For lngRow = 1 To scpList.Count
        arrVals(lngRow, 1) = scpList.Keys(lngRow - 1)
    Next lngRow
End If

If IsArray(arrVals) Then
    For lngRow = LBound(arrVals, 1) To UBound(arrVals, 1)
        strVal = arrVals(lngRow, intCol)
        For intColCurr = intCol + 1 To intCol + intCols - 1
            strVal = strVal & strDelim & arrVals(lngRow, intColCurr)
        Next intColCurr
        If Not Loadscp.Exists(strVal) Then
            Loadscp.Item(strVal) = lngRow
        End If
    Next lngRow
End If

End Function

循环不是问题所在。在
单元格中发生的事情到达此处的另一个文件
就是问题所在。如果数据在表中，考虑使用POWER查询并将两个表合并到一个关键字段上。如果您对PrimelListIoo数据进行排序，并使用二进制搜索，则会更快得多。你能这样做吗？@MacroMarc我不熟悉二进制搜索，如果你是说VLOOKUP，我昨天就放弃了。听起来像是两个表上的内部联接代码完全运行，但它没有向另一个表添加任何数据，一步一步地进行（调试）似乎没有显示它所缺少的代码。它是否曾经到达
”单元格，并在此处到达另一个文件的
部分？是的，每一行。这可能是我粘贴单元格的方式，但它对我制作的循环有效。这里有一行：
planillaDestino.Cells（filaIndiceDestino，“P”）.Value=planillaFuente.Cells（filaIndiceFuente，“D”）.Value
好的，我知道发生了什么<在上面的代码段中，code>filaIndiceFuente=filafunteultima
，因此您可能总是返回一个空值。您需要引用字典值，如前所述，字典值是指向
planillaFuente
中的行的指针。您需要将
planillaFuente.Cells（filaIndiceFuente，“d”）.Value
更改为
planillaFuente.Cells（dict（CStr（planillaDestino.Range（“A”&filaIndiceDestino.Value）），“d”）.Value
以引用字典中存储的行的“d”列。非常感谢！终于有时间尝试了，到目前为止它还在工作（目前正在检查随机行）。另外，是否可以调用一个长范围（不是整行）而不是调用每个列？当它运行excel相关的所有内容时，所有内容都变为空白（字面上），因此我看不到状态。但我会考虑下一次尝试！谢谢
Public Function Loadscp(ByVal varList As Variant, Optional ByVal intCol As Integer = 1, _
Optional ByVal intCols As Integer = 1, Optional ByVal strDelim As String = ".") As Scripting.Dictionary

Dim scpList             As Scripting.Dictionary

Dim arrVals             As Variant

Dim lngLastRow          As Long
Dim lngRow              As Long
Dim intABSCol           As Integer
Dim intColCurr          As Integer
Dim strVal              As String
Dim intRngCol           As Integer

Set Loadscp = New Scripting.Dictionary
Loadscp.CompareMode = vbTextCompare

intABSCol = Abs(intCol)
If IsArray(varList) Then
    arrVals = varList
ElseIf TypeName(varList) = "Range" Then
    intRngCol = varList.Column
    lngLastRow = LastRow(varList.Parent, intCol)

    If lngLastRow > varList.Row Then
        arrVals = varList.Offset(1, intABSCol - 1).Resize(lngLastRow - varList.Row, 1)
    End If
ElseIf TypeName(varList) = "Dictionary" Then
    Set scpList = varList
    ReDim arrVals(1 To scpList.Count, 1 To 1)
    For lngRow = 1 To scpList.Count
        arrVals(lngRow, 1) = scpList.Keys(lngRow - 1)
    Next lngRow
End If

If IsArray(arrVals) Then
    For lngRow = LBound(arrVals, 1) To UBound(arrVals, 1)
        strVal = arrVals(lngRow, intCol)
        For intColCurr = intCol + 1 To intCol + intCols - 1
            strVal = strVal & strDelim & arrVals(lngRow, intColCurr)
        Next intColCurr
        If Not Loadscp.Exists(strVal) Then
            Loadscp.Item(strVal) = lngRow
        End If
    Next lngRow
End If

End Function