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

Question

"bFO data“表包含约25500行数据，"Q2C data”表包含约87750行数据。我先遍历bFO数据，然后遍历Q2C数据，以匹配8位数字。当找到匹配项时，我用来自每个工作表的2条数据编译8位数字，所有这些数据都在匹配的工作表上。

我试图提高效率的方法是创建一个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."

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