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

Question

“ bFO數據”表包含約25500行數據，“ Q2C數據”表包含〜87750行。 我正在遍歷bFO數據，然后遍歷Q2C數據以匹配8位數字。 找到匹配項后，我將8位數字與每張工作表中的2條數據一起編譯到匹配工作表中。

我試圖提高效率的嘗試是制作一個bFO數據臨時表，並在找到匹配項后刪除行。 麻煩的是，我知道bFO中存在部分重復的行，需要將匹配的數字保留在臨時表中以聚合更完整的數據集。

我希望能獲得有關更快的循環技術的建議，因為我的double 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."

在你的循環中。 它可以使您及時了解最新情況。