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

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

将大块数据移入/从Variant数组移出（并循环该Variant数组而不引用表单）
使用Range.Find避免循环
使用VLookup / HLookup / Match避免循环
使用Range.SpecialCells减小范围引用的大小
避免活动：这里您隐含了对ActiveWorkbook的引用

在您的情况下，我建议将Variant Array和Match结合使用，像这样

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上的所有现有数据和公式，并且仅在存在匹配项的地方覆盖}

工作表和副本行中的VBA Excel匹配值

1 个答案: