VBA Excel Соответствие значений в листах и ​​копирование строк

Question

Я довольно новичок в программировании на VBA в Excel. Мой код работает, но он слишком медленный.

Не могли бы вы, ребята, помочь мне ускорить мою задачу.

В Sheet2 содержится около 42 000 элементови sheet1 варьируется от 100 до 1000

В основном я ищу значение в 2 листах, когда есть совпадение, я копирую информацию в sheet1 из sheet2.

См. мой код ниже.

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 для уменьшения размера ссылки на диапазон
• Избегать активных: здесь у вас есть неявные ссылки на 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, и перезаписывать только при совпадении}