1
\$\begingroup\$

I'm trying to copy values from one sheet to another sheet if a value exists. The code runs great on around 500 rows but very slowly on 5000 rows.

Is there any way I can speed it up?

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
\$\endgroup\$
3
  • \$\begingroup\$ Why are you using Debug.Print? \$\endgroup\$ Mar 15, 2018 at 3:27
  • \$\begingroup\$ @Raystafarian Just for testing, it will get removed once the code is ready- \$\endgroup\$
    – 0m3r
    Mar 15, 2018 at 3:33
  • \$\begingroup\$ Can you post a sample workbook, might be easier to recommend performance tweaks understanding the full context. \$\endgroup\$ Mar 16, 2018 at 21:50

1 Answer 1

2
\$\begingroup\$

There are a lot of aspects to this code. I'll just address your loops, but first

First - while this notation works

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

It's not standard. It's actually very strange.

If .Cells(x,1) = LPN_NUM

Is more like how it would be expected to be used.


Loops

I don't like DO UNTIL loops. I especially don't like a DO UNTIL in my DO UNTIL. Also, let's take a look at these

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

What's happening here? I can't really tell by just looking at it. Let's start with some structure -

    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

Okay, now we can use some FOR NEXT loops

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

Right, that feels better.

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

Look, in fact you've already written that code.


Okay, let's talk about speed in your loops.

Things like this

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

Take a lot of resources. Especially within two DO UNTIL loops. Looking at it, it kind of looks like you want something like this

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

Now you can loop through the items in the arrays rather than on the sheet. Populate the arrays and then put the array on the sheet in one fell swoop.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.