Копировать/вставить значения на двух листах


Я пытаюсь скопировать значения из одного листа на другой лист, если существует значение. Код отлично работает на около 500 строк, но очень медленно на 5000 строк.

Есть ли способ я могу ускорить его?

Option Explicit
Public Sub ExampleCycleCount()
    ' updating off
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = xlManual
    End With

    Dim FileName As String
    Dim FilePath As String
        FileName = Format(Now, "YYYY MM DD HHMM") & " " & _
                   Sheets("WarehouseInventory").Range("A1").Text
        FilePath = Environ("USERPROFILE") & "\Documents\Cycle Count"

    Debug.Print FileName

    ActiveWorkbook.SaveAs FileName:=FilePath & "\" & FileName

    ' Check if active sheet name is scan report
    If Not ActiveWorkbook.ActiveSheet.Name = "Scan Report" Then
        ActiveWorkbook.ActiveSheet.Name = "Scan Report"
    End If

    Dim SCAN_REPORT As Worksheet
    Dim INVENTORY_REPORT As Worksheet
    Set SCAN_REPORT = ActiveWorkbook.Worksheets("Scan Report")
    Set INVENTORY_REPORT = ActiveWorkbook.Worksheets("WarehouseInventory")

    ' Add top row for heading -
    With SCAN_REPORT
        If Not [A1].Value = "LPN" Then
            Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            [A1].Value = "LPN"
            [B1].Value = "PART NUMBER"
            [C1].Value = "SERIAL NUMBER"
            [D1].Value = "SYSTEM BIN"
            [E1].Value = "SCANNED BIN"
            [F1].Value = "COMMENT'S"
        End If

        ' set filter mode
        If ActiveSheet.AutoFilterMode = False Then
            [A1].AutoFilter
        End If

        With ActiveWindow
            .SplitColumn = 0
            .SplitRow = 1
            .FreezePanes = True
        End With

    End With

    Dim i%, x% ' as long
        i = 2 ' Start on row 2 - SCAN_REPORT
        x = 3 ' Start on row 3 - INVENTORY_REPORT

    Dim BIN_NUM As String
    Dim LPN_NUM As String

    With SCAN_REPORT
        Do Until IsEmpty(.Columns(1).Cells(i))
            DoEvents

            If Len(.Columns(1).Cells(i).Value) <= 6 Then
                BIN_NUM = .Columns(1).Cells(i).Value
                Debug.Print BIN_NUM 'Immediate Window
            End If

            If Len(.Columns(1).Cells(i).Value) = 12 Then
                Debug.Print .Columns(1).Cells(i).Address
                LPN_NUM = .Columns(1).Cells(i).Value

                With INVENTORY_REPORT
                    Do Until IsEmpty(.Columns(1).Cells(x))
                        DoEvents

                        If .Columns(1).Cells(x).Value = LPN_NUM Then
                            ' Copy Paste from inventory to scan sheet
                            SCAN_REPORT.Columns(1).Cells(i).Offset(0, 1).Value = _
                            INVENTORY_REPORT.Columns(1).Cells(x).Offset(0, 1).Value

                            SCAN_REPORT.Columns(1).Cells(i).Offset(0, 2).Value = _
                            INVENTORY_REPORT.Columns(1).Cells(x).Offset(0, 2).Value

                            SCAN_REPORT.Columns(1).Cells(i).Offset(0, 3).Value = _
                            INVENTORY_REPORT.Columns(1).Cells(x).Offset(0, 3).Value

                            SCAN_REPORT.Columns(1).Cells(i).Offset(0, 4).Value = BIN_NUM

                            ' Check if bin row match
                            If Not SCAN_REPORT.Columns(1).Cells(i).Offset(0, 3) _
                                                         .Value = BIN_NUM Then

                                SCAN_REPORT.Columns(1).Cells(i).Offset(0, 5) _
                                           .Value = "SYSTEM/SCAN BIN DON'T MATCH"
                            End If

                            Exit Do
                        End If

                        x = x + 1
                    Loop

                    x = 2
                End With 'INVENTORY_REPORT

                If SCAN_REPORT.Columns(1).Cells(i).Offset(0, 4).Value = "" Then
                    SCAN_REPORT.Columns(1).Cells(i).Offset(0, 4).Value = BIN_NUM
                    SCAN_REPORT.Columns(1).Cells(i).Offset(0, 5).Value = "LPN NOT FOUND"
                End If
            Else
                If Len(.Columns(1).Cells(i).Value) >= 7 Then
                    SCAN_REPORT.Columns(1).Cells(i).Offset(0, 5) _
                                          .Value = "ERROR / SCANNED IN " & BIN_NUM
                End If
            End If

            i = i + 1
        Loop

    End With 'SCAN_REPORT

    With INVENTORY_REPORT
        .Range("H2").Value = "COMMENTS'S"
        .Range("H2").Font.Bold = True
        .Range("A2").AutoFilter
    End With

    x = 0 ' INVENTORY_REPORT
    i = 0 ' SCAN_REPORT

    Dim List As Scripting.Dictionary
    Set List = New Scripting.Dictionary

    With SCAN_REPORT
        Dim Rpt_LRow As Long
            Rpt_LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Dim Rpt_Data() As Variant
            Rpt_Data = .Range(.Cells(1, 1), .Cells(Rpt_LRow, 1)).Value

        For x = LBound(Rpt_Data) To UBound(Rpt_Data) Step 1
            DoEvents
            Debug.Print Rpt_Data(x, 1)
            On Error Resume Next ' For duplicates
            List.Add Rpt_Data(x, 1), x
            On Error GoTo 0
        Next
    End With

    With INVENTORY_REPORT
        Dim Inv_LRow As Long
            Inv_LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

        Dim Inv_Data() As Variant
            Inv_Data = .Range(.Cells(1, 1), .Cells(Inv_LRow, 1)).Value

        For i = LBound(Inv_Data) To UBound(Inv_Data) Step 1
            DoEvents
            If List.Exists(Inv_Data(i, 1)) Then
                .Columns(1).Cells(i).Offset(0, 7).Value = "LPN SCANNED"
            Else
                .Columns(1).Cells(i).Offset(0, 7).Value = "LPN NOT SCAN"
            End If
        Next
    End With

    ' Check for dupes
    With SCAN_REPORT.Range("A:A")
        .FormatConditions.AddUniqueValues
        .FormatConditions(1).DupeUnique = xlDuplicate
        .FormatConditions(1).Interior.Color = 13551615
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = xlAutomatic
    End With

End Sub


122
1
задан 15 марта 2018 в 02:03 Источник Поделиться
Комментарии
1 ответ

Есть много аспектов этого кода. Я просто адрес вашей петли, но сначала

Первая - в то время как такая запись работает


If .Columns(1).Cells(x).Value = LPN_NUM Then

Это не стандарт. Это на самом деле очень странно.

If .Cells(x,1) = LPN_NUM

Более как, как можно было бы ожидать, чтобы быть использованы.


Петли

Мне не нравится DO UNTIL петли. Особенно мне не нравятся DO UNTIL в моем DO UNTIL. Кроме того, давайте взглянем на этих


With SCAN_REPORT
Do Until IsEmpty(.Columns(1).Cells(i))
DoEvents
With INVENTORY_REPORT
Do Until IsEmpty(.Columns(1).Cells(x))
DoEvents
x = x + 1
Loop
x = 2
End With
i = i + 1
Loop
End With

Что здесь происходит? Я не могу сказать, просто глядя на него. Давайте начнем с некоторой структурой -

    Dim scanLastRow As Long
Dim inventoryLastRow As Long
scanLastRow = SCAN_REPORT.Cells(Rows.Count, 1).End(xlUp).Row
inventoryLastRow = INVENTORY_REPORT.Cells(Rows.Count, 1).End(xlUp).Row

Ладно, теперь мы можем использовать некоторые FOR NEXT петли

    For x = 1 To scanLastRow
With INVENTORY_REPORT
For i = 1 To inventoryLastRow
Next
End With
Next

Прав, что чувствует себя лучше.


Dim Rpt_LRow As Long
Rpt_LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim Inv_LRow As Long
Inv_LRow = .Cells(.Rows.Count, 1).End(xlUp).Row

Посмотри, ведь вы уже написали, что код.


Ладно, давайте поговорим о скорости в ваших петель.

Такие вещи


SCAN_REPORT.Columns(1).Cells(i).Offset(0, 1).Value = _
INVENTORY_REPORT.Columns(1).Cells(x).Offset(0, 1).Value

Займет много ресурсов. Особенно в течение двух DO UNTIL петли. Глядя на это, кажется, вы хотите нечто подобное

Dim invArray As Variant
Dim scanArray As Variant
Dim scanLastRow As Long
Dim inventoryLastRow As Long
scanLastRow = SCAN_REPORT.Cells(Rows.Count, 1).End(xlUp).Row
inventoryLastRow = INVENTORY_REPORT.Cells(Rows.Count, 1).End(xlUp).Row
scanArray = SCAN_REPORT.Range(.Cells(1, 1), .Cells(scanLastRow, 4))
inarray = INVENTORY_REPORT.Range(.Cells(1, 1), .Cells(inventoryLastRow, 4))
Dim scanIndex As Long
Dim invIndex As Long
For scanIndex = LBound(scanArray) To UBound(scanArray)
LPN_NUM = scanArray(scanIndex)
For invIndex = LBound(invArray) To UBound(invArray)
If invArray(invIndex) = LPN_NUM Then
'stuff
Else
'other stuff
End If
Next
Next

Теперь вы можете перебрать элементы в массивах, а не на листе. Заполнить массивы и затем положить массив на лист одним махом.

2
ответ дан 15 марта 2018 в 04:03 Источник Поделиться