VBA Excel匹配工作表和复制行中的值

Question

我对在 excel 中使用 VBA 进行编程非常陌生，我的代码可以正常工作，但它太慢了。

你们能帮我加快我的任务吗？

Sheet2 有大约 42.000 个项目，而 sheet1 从 100 到 1000 不等

基本上，当有匹配项时，我会在 2 张纸中查找一个值，我将信息从 sheet2 复制到 sheet1。

在下面查看我的代码。

Sub CheckAML()

Dim i As Long
Dim j As Long
Sheet1LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

    For j = 1 To Sheet1LastRow
        For i = 1 To Sheet2LastRow
            If Worksheets("Sheet1").Cells(j, 1).Value = Worksheets("Sheet2").Cells(i, 1).Value Then
                Worksheets("Sheet1").Cells(j, 3).Value = Worksheets("Sheet2").Cells(i, 2).Value
                Worksheets("Sheet1").Cells(j, 4).Value = Worksheets("Sheet2").Cells(i, 3).Value
                Worksheets("Sheet1").Cells(j, 5).Value = Worksheets("Sheet2").Cells(i, 4).Value
            Else
            End If
    Next i
Next j

Application.ScreenUpdating = True

End Sub

如果 Sheet2 可以是一个单独的工作簿，那就太好了。

Answer 1

在 VBA 中对工作表或单元格的任何引用都是缓慢的操作。只做一些不会引人注目，但做很多会减慢代码速度。在这里，在您的 for 循环中，您最多可以执行 42,000 * 1,000 * 8 = 332,000,000

快速编码的关键是尽可能减少工作表引用的数量。常用技术包括

• 将大块数据移入/移出变量数组（并在不引用工作表的情况下循环该变量数组）
• 使用 Range.Find 避免循环
• 使用 VLookup / HLookup / Match 避免循环
• 使用 Range.SpecialCells 减小范围引用的大小
• Avoid Active：这里有对 ActiveWorkbook 的隐式引用

在你的情况下，我建议一个变体数组和匹配的组合，像这样

Sub CheckAML()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim j As Long
    Dim ws1Range As Range
    Dim ws1Data As Variant
    Dim ws1NewData As Variant
    Dim ws2Range As Range
    Dim rw As Variant
    Dim Newdata As Variant

    Set wb1 = ThisWorkbook 'the workbook containing the code
    Set wb2 = Application.Workbooks("NameOfWorkbook.xlsm")
    Set ws1 = wb1.Worksheets("Sheet1")
    Set ws2 = wb2.Worksheets("Sheet2")

    With ws1
        Set ws1Range = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With

    With ws2
        Set ws2Range = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With

    ws1Data = ws1Range.Value
    ws1NewData = ws1Range.Offset(0, 2).Resize(, 3).Formula

    For j = 1 To UBound(ws1Data, 1)
        rw = Application.Match(ws1Data(j, 1), ws2Range, 0)
        If Not IsError(rw) Then
            Newdata = ws2.Cells(rw, 2).Resize(, 3).Value
            ws1NewData(rw, 1) = Newdata(1, 1)
            ws1NewData(rw, 2) = Newdata(1, 2)
            ws1NewData(rw, 3) = Newdata(1, 3)
        End If
    Next

    ws1Range.Offset(, 2).Resize(, 3).Formula = ws1NewData

End Sub

_{注意：这将保留 ws1 上的所有现有数据和公式，并且仅覆盖匹配项}