提高跨工作表匹配值的效率 excel-vba

Question

“bFO 数据”表包含约 25500 行数据，“Q2C 数据”表包含约 87750 行数据。我正在遍历 bFO 数据，然后是 Q2C 数据以匹配 8 位数字。找到匹配项后，我将 8 位数字与每张表中的 2 条数据全部放在匹配表上。

我的提高效率的尝试是制作 bFO 数据的临时表，并在找到匹配项后删除行。麻烦的是，我知道 bFO 中有部分重复的行需要匹配的数字才能保留在临时表中以聚合更完整的数据集。

我希望获得有关更快循环技术的建议，因为我的双 while 循环需要几分钟才能完成前 1000 行。提前感谢您提供的任何帮助！

Sub MatchQuoteData()
Dim lastRowbFO, lastColbFO, lastRowQ2C, lastColQ2C, tempRowTot, q2cHDRb, q2cHDRq
Dim rowB, rowQ, targRow As Integer
Dim numB, numQ

q2cHDRb = ScanColHDR("Q2C#")
q2cHDRq = ScanColHDR("q2c_nbr")

    ' make new sheet
Sheets.Add.Name = "Matching Q2C details"
Worksheets("Matching Q2C details").Move After:=Sheets(Sheets.Count)
    'generate header for matching sheet
Worksheets("Matching Q2C details").Range("A1").Value = "Q2C Created Date"
Worksheets("Matching Q2C details").Range("B1").Value = "bFO Created Date"
Worksheets("Matching Q2C details").Range("C1").Value = "Q2C Amount"
Worksheets("Matching Q2C details").Range("D1").Value = "bFO Amount"
Worksheets("Matching Q2C details").Range("E1").Value = "Q2C #"

    'set up temp sheet and delete header file
Sheets("Q2C Data").Copy After:=Sheets("Q2C Data")
    ActiveSheet.Name = "temp"
    Worksheets("temp").Rows(1).Delete

    'define the bounds of the data sheets
With Worksheets("bFO Data")
lastRowbFO = .Cells(.Rows.Count, "A").End(xlUp).row
lastColbFO = .Cells(1, Columns.Count).End(xlToLeft).Column
End With
With Worksheets("Q2C Data")
lastRowQ2C = .Cells(.Rows.Count, "A").End(xlUp).row
lastColQ2C = .Cells(1, Columns.Count).End(xlToLeft).Column
End With

    'continue to fill matching sheet header
col = 6
While col < lastColbFO + 3
    Worksheets("Matching Q2C details").Cells(1, col).Value = Worksheets("bFO Data").Cells(1, col - 2).Value
    col = col + 1
Wend
While col < lastColbFO + 3 + lastColQ2C
    Worksheets("Matching Q2C details").Cells(1, col).Value = Worksheets("Q2C Data").Cells(1, col - 2).Value
    col = col + 1
Wend

MsgBox "matching"
rowB = 2
targRow = 2
tempRowTot = lastRowQ2C
While rowB < lastRowbFO
    numB = Worksheets("bFO Data").Cells(rowB, q2cHDRb).Value
    If (Len(numB) = 8) Then
        rowQ = 2
        While rowQ < tempRowTot
            numQ = Worksheets("temp").Cells(rowQ, q2cHDRq)
            If (numQ = numB) Then
                    Worksheets("Matching Q2C details").Cells(targRow, 1).Value = Worksheets("Q2C data").Cells(rowQ, 1)
                    Worksheets("Matching Q2C details").Cells(targRow, 2).Value = Worksheets("bFO data").Cells(rowB, 1)
                    Worksheets("Matching Q2C details").Cells(targRow, 3).Value = Worksheets("Q2C data").Cells(rowQ, 3)
                    Worksheets("Matching Q2C details").Cells(targRow, 4).Value = Worksheets("bFO data").Cells(rowB, 3)
                    Worksheets("Matching Q2C details").Cells(targRow, 5).Value = numB
                    targRow = targRow + 1
                    'remove matching data and decrement the search window
                    'Worksheets("temp").Rows(rowQ).Delete
                    'tempRowTot = tempRowTot - 1
            End If
            rowQ = rowQ + 1
        Wend
    End If
    rowB = rowB + 1
Wend

End Sub

Function ScanColHDR(colName As String)
Dim col, ct, row, colHDR As Integer

ct = 0
col = 0
row = 0
colHDR = 0
While ct <> 1
    col = col + 1
    row = 1
    cntHDR = Cells(row, col).Value
    If (cntHDR = colName) Then
        colHDR = col
        ct = ct + 1
    End If
    If col > 50 Then
        ct = 1
    End If
Wend
ScanColHDR = colHDR
End Function

Answer 1

快速提示：每当使用长循环时，我喜欢添加

DoEvents

作为循环的第一行。它运行得更快并防止冻结。

另一种方式，不一定是为了速度，但它确实让人感觉更快，是添加类似的东西

Application.StatusBar = "Updating. Row" & (rowB) & " of " & (lastRowbFO)
& " complete."

在你的循环中。它会让您及时了解正在发生的事情。