Question

我正在匹配单独文件上的ID，如果发生匹配，则源中的行将被检索到另一个文件。我对两个文件都做了一个FOR语句来扫描每一行，如果我理解正确的话，直到循环结束，这是216M +的计算，源工作簿中有27000行以上，另外约8000行。我已经实现了screenUpdating = False和xlCalculationManual。但是我在这里，我已经等了大约30分钟，并且没有代码完成的迹象（VBA编辑器和Excel都“没有响应”）。

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value
    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then

        'CELLS GET TO THE OTHER FILE HERE

        End If
    Next filaIndiceDestino
Next filaIndiceFuente

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

Answer 1

通常，当我要遍历较大的数据集进行匹配时，我发现使用Dictionary甚至比。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

Answer 2

我可能会更进一步，将数据加载到数组中，然后遍历数组。由于读取数组数据时发生偏移，因此索引将减少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

Answer 3

首先，我将添加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 = ""

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

Answer 4

首先对按列A递增的planillaDest范围进行排序，然后：

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

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

4 个答案: