Question

我正在寻找一种方法来加速此代码，因为我的计算机需要20到30分钟才能运行。它本质上遍历工作表“ A”中的列值列表，如果与工作表“ B”中的列值匹配，它将把整个相应行拖到工作表“匹配”中。

Sub MatchSheets()
Dim lastRowAF As Integer
Dim lastRowL As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean

Application.ScreenUpdating = False

lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRowAF
foundTrue = False
For j = 1 To lastRowL

    If Sheets("FHA").Cells(i, 32).Value = Sheets("New Construction").Cells(j, 12).Value Then
        foundTrue = True
        Exit For
    End If

Next j

If foundTrue Then
    Sheets("FHA").Rows(i).Copy Destination:= _
    Sheets("Match").Rows(lastRowM + 1)
    lastRowM = lastRowM + 1
End If

Next i

Application.ScreenUpdating = True

End Sub

Answer 1

对集合进行了优化，以查找值。通常使用Collection和Array的组合是匹配两个列表的最佳方法。 20K行X 54列（140K值）花了10.87秒的时间将此代码复制到速度较慢的PC上。

Sub NewMatchSheets()
    Dim t As Double: t = Timer
    Const NUM_FHA_COLUMNS As Long = 54, AF As Long = 32
    Dim list As Object
    Dim key As Variant, data() As Variant, results() As Variant
    Dim c As Long, r As Long, count As Long
    ReDim results(1 To 50000, 1 To 100)

    Set list = CreateObject("System.Collections.ArrayList")

    With ThisWorkbook.Worksheets("New Construction")
        data = .Range("L1", .Cells(.Rows.count, "L").End(xlUp)).Value
        For Each key In data
            If key <> "" Then
                If Not list.Contains(key) Then list.Add key
            End If
        Next
    End With

    With ThisWorkbook.Worksheets("FHA")
        data = .Range(.Range("A1").Resize(1, NUM_FHA_COLUMNS), .Cells(.Rows.count, AF).End(xlUp)).Value
        For r = 1 To UBound(data)
            key = data(r, AF)
            If list.Contains(key) Then
                count = count + 1
                For c = 1 To UBound(data, 2)
                    results(count, c) = data(r, c)
                Next
            End If
        Next
    End With

    If count = 0 Then Exit Sub

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True

    With ThisWorkbook.Worksheets("Match")
        With .Cells(.Rows.count, "A").End(xlUp)
            .Offset(1).Resize(count, NUM_FHA_COLUMNS).Value = results
        End With
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    Debug.Print Round(Timer - t, 2)
End Sub

Answer 2

使用变体数组：

Sub MatchSheets()
Dim lastRowAF As Long
Dim lastRowL As Long
Dim lastRowM As Long


Application.ScreenUpdating = False

lastRowAF = Sheets("FHA").Cells(Sheets("FHA").Rows.Count, "AF").End(xlUp).Row
lastRowL = Sheets("New Construction").Cells(Sheets("New Construction").Rows.Count, "L").End(xlUp).Row
lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row

Dim FHAArr As Variant
    FHAArr = Sheets("FHA").Range(Sheets("FHA").Cells(1, 1), Sheets("FHA").Cells(lastRowAF, Columns.Count).End(xlToLeft)).Value

Dim NewConArr As Variant
    NewConArr = Sheets("New Construction").Range(Sheets("New Construction").Cells(1, 12), Sheets("New Construction").Cells(lastRowL, 12)).Value

Dim outarr As Variant
ReDim outarr(1 To UBound(FHAArr, 1), 1 To UBound(FHAArr, 2))

Dim k As Long
k = 0
Dim l As Long

For i = 1 To lastRowAF
    For j = 1 To lastRowL
        If FHAArr(i, 32) = NewConArr(j, 1) Then
            For l = 1 To UBound(FHAArr, 2)
                k = k + 1
                outarr(k, l) = FHAArr(i, l)
            Next l
            Exit For
        End If
    Next j
Next i

Sheets("Match").Cells(lastRowM + 1, 1).Resize(UBound(outarr, 1), UBound(outarr, 2)).Value = outarr

Application.ScreenUpdating = True

End Sub

Answer 3

_{FHA工作表：2500行x 50列
新建建筑工作表：500行x 1列L
匹配工作表：从FMA传输450次
。}经过时间： 0.13 seconds

摆脱所有嵌套循环并使用数组。

您的叙述似乎暗示一个值可能存在多个匹配项，但是您的代码只寻找一个匹配项，然后寻找Exit For。我将处理两种情况中的后一种情况。

Sub MatchSheets()

    Dim i As Long, j As Long
    Dim vFM As Variant, vNC As Variant

    Debug.Print Timer

    With Worksheets("New Construction")
        vNC = .Range(.Cells(1, "L"), _
                     .Cells(.Rows.Count, "L").End(xlUp)).Value2
    End With

    With Worksheets("FHA")
        vFM = .Range(.Cells(1, "A"), _
                     .Cells(.Rows.Count, _
                            .Cells(1, .Columns.Count).End(xlToLeft).Column).End(xlUp)).Value2
    End With

    ReDim vM(LBound(vFM, 2) To UBound(vFM, 2), 1 To 1)

    For i = LBound(vFM, 1) To UBound(vFM, 1)
        If Not IsError(Application.Match(vFM(i, 32), vNC, 0)) Then
            For j = LBound(vFM, 2) To UBound(vFM, 2)
                vM(j, UBound(vM, 2)) = vFM(i, j)
            Next j
            ReDim Preserve vM(LBound(vFM, 2) To UBound(vFM, 2), LBound(vM, 2) To UBound(vM, 2) + 1)
        End If
    Next i

    With Worksheets("match")
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(UBound(vM, 2), UBound(vM, 1)) = _
            Application.Transpose(vM)
    End With

    Application.ScreenUpdating = True

    Debug.Print Timer

End Sub

Answer 4

尝试更改此行：

Sheets("FHA").Rows(i).Copy Destination:= _
Sheets("Match").Rows(lastRowM + 1)

对于以下行：

Sheets("Match").Rows(lastRowM + 1).Value for Sheets("FHA").Rows(i).value

如果您确实需要剃光毫秒，也可以将lastRowM设置为：

lastRowM = Sheets("Match").Cells(Sheets("Match").Rows.Count, "A").End(xlUp).Row + 1

并使用：

Sheets("Match").Rows(lastRowM).Value for Sheets("FHA").Rows(i).value

因此，每当您遍历代码的那部分时，便可以为您节省更多的费用

使用列匹配加快从数据中提取行的速度

4 个答案: