Looks at order data and arranges it to focus on order locations

Question

I have a sheet that order a bunch of information on individual orders. Order numbers are in column A, other information is in columns B-P, and then product numbers are the headers for columns Q-DL. The cells within the order number and product number contains an integer that corresponds to the location that product is placed.

My code creates a new sheet that loops through all of these rows and then each cell within the row and compares it to headers of the new sheet which contain the location numbers.
If a cell matches the location header, it puts a 1 in the corresponding cell of the new sheet to indicate that product is needed from that location and a 0 if it does not match.

My code works, but it works very slow. So advice on how to make it faster would be appreciated.

Sub PopulateData()
    Dim s1 As Worksheet: Dim s2 As Worksheet
    Dim rng As Range: Dim rng2 As Range
    Dim cell: Dim header

    With Application
        .ScreenUpdating = False
    End With

    With ThisWorkbook
        Set s1 = .Sheets("OrderLvl")
        Set s2 = .Sheets("sheet1")
    End With
    With s1
        Set rng = Range(.Cells(4, 16), .Cells(.Cells(Rows.Count, 116).End(xlUp).row, 116))
    End With
    Set rng2 = Range(s2.Cells(3, 2), s2.Cells(3, 265))

    For Each cell In rng.Cells
        For Each header In rng2.Cells
            If cell.Value = 0 Then

            ElseIf cell.Value <> header.Value And s2.Cells(cell.row, header.Column).Value <> 1 Then
                s2.Cells(cell.row, header.Column).Value = 0 
            Else
                s2.Cells(cell.row, header.Column).Value = 1

            ' indicates that this order features a line from this location
            End If
        Next header
    Next cell
    With Application
        .ScreenUpdating = True
    End With
End Sub

Answer 1

A quick fix would be to change:

For Each cell In rng.Cells
    For Each header In rng2.Cells
        If cell.Value = 0 Then

        ElseIf cell.Value <> header.Value And s2.Cells(cell.row, header.Column).Value <> 1 Then
            s2.Cells(cell.row, header.Column).Value = 0
        Else
            s2.Cells(cell.row, header.Column).Value = 1 ' indicates that this order features a line from this location
        End If
    Next header
Next cell

to

For Each cell In rng.Cells
  If cell.Value <> 0 Then
    For Each header In rng2.Cells
        If cell.Value <> header.Value And s2.Cells(cell.row, header.Column).Value <> 1 Then
            s2.Cells(cell.row, header.Column).Value = 0
        Else
            s2.Cells(cell.row, header.Column).Value = 1 ' indicates that this order features a line from this location
        End If
    Next header
  End If
Next cell

That way you only loop through the headers if the cell value isn't 0, instead of looking at every header for every cell no matter its value, then checking to see if it's a cell you're interested in.

It also gets rid of the awkward If x do nothing else do something construct.

Answer 2

It looks like you are trying to find the value of cell in the rng2.Cells. It might be quicker to use the Find method:

Set header = rng2.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
s2.Cells(cell.row, header.Column).Value = 1 ' indicates that this order features a line from this location

This method might leave you with blank cells though. Are you able to pre-fill all the cells with zero? Use something like before you start the For Each cell... loop:

' Pre-fill with zeroes
rng2.Offset(RowOffset:=1).Resize(RowSize:=rng.Rows.Count).Value = 0

Another alternative is to use a Dictionary to store the rng2 values as the keys and the column numbers as the value. You'll need to go into Tools -> References and select the Microsoft Scripting Runtime to use early binding. Your code might then become this:

Sub PopulateDataUsingDict()
    Dim s1 As Worksheet: Dim s2 As Worksheet
    Dim rng As Range: Dim rng2 As Range
    Dim cell As Range: Dim header As Range
    Dim headersDict As Scripting.Dictionary

    With Application
        .ScreenUpdating = False
    End With

    With ThisWorkbook
        Set s1 = .Sheets("OrderLvl")
        Set s2 = .Sheets("sheet1")
    End With
    With s1
        Set rng = Range(.Cells(4, 16), .Cells(.Cells(Rows.Count, 116).End(xlUp).Row, 116))
    End With
    Set rng2 = Range(s2.Cells(3, 2), s2.Cells(3, 265))

    ' Pre-fill with zeroes
    rng2.Offset(RowOffset:=1).Resize(RowSize:=rng.Rows.Count).Value = 0

    ' Populate the dictionary with location values and column number
    Set headersDict = New Dictionary
    For Each header In rng2.Cells
        headersDict.Add header.Value, header.Column
    Next header

    For Each cell In rng.Cells
        If cell.Value <> 0 Then
            If headersDict.Exists(cell.Value) Then
                ' indicates that this order features a line from this location
                s2.Cells(cell.Row, headersDict.Item(cell.Value)).Value = 1
            End If
        End If
    Next cell
    With Application
        .ScreenUpdating = True
    End With
End Sub

Answer 3

Two quick thoughts.

1. Make sure calculation mode is set to manual at the start (when you do your screen updating)

   Application.Calculation = xlCalculationManual

2. After this line

   s2.Cells(cell.row, header.Column).Value = 1

have

Exit For

Which will break the immediate for loop and stop you double checking over and over again if you've already found it.

You could also consider writing the data to an array before processing, as one big thing that slows VBA is the constant referring to and from a worksheet, but this is a slightly longer winded fix.

Answer 4

I added code to save present parameters on few functionalities and turn them off while your code is running, and then put them back in their initial states at the end.

At the end of your code, you also need to free your object variables like this Set S1 = Nothing

And added few . (point) in Set Rng = Range to have a fully referenced object.

I put a timer so that you can see how long it is taking.

And finally, I changed Cell range variable to rCell ti avoid any confusion for the interpreter.

Here is the code reviewed and tested :

Sub PopulateData()
Dim S1 As Worksheet, _
    S2 As Worksheet, _
    Rng As Range, _
    Rng2 As Range, _
    rCell As Range, _
    Header As Range, _
    ScreenUpdateState As Boolean, _
    StatusBarState As Boolean, _
    CalcState As Long, _
    EventsState As Boolean, _
    DisplayPageBreaksState As Boolean, _
    StartTime As Long

StartTime = Timer

With Application
    'Get current state of few Excel settings
    ScreenUpdateState = .ScreenUpdating
    StatusBarState = .DisplayStatusBar
    CalcState = .Calculation
    EventsState = .EnableEvents
    'Turn off few Excel functionalities so your code runs faster
    .ScreenUpdating = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
DisplayPageBreaksState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

With ThisWorkbook
    Set S1 = .Sheets("OrderLvl")
    Set S2 = .Sheets("sheet1")
End With

With S1
    Set Rng = Range(.Cells(4, 16), .Cells(.Cells(.Rows.Count, 116).End(xlUp).Row, 116))
End With
Set Rng2 = Range(S2.Cells(3, 2), S2.Cells(3, 265))


For Each rCell In Rng.Cells
    If rCell.Value <> 0 Then
        For Each Header In Rng2.Cells
            If rCell.Value <> Header.Value And S2.Cells(rCell.Row, Header.Column).Value <> 1 Then
                S2.Cells(rCell.Row, Header.Column).Value = 0
            Else
                S2.Cells(rCell.Row, Header.Column).Value = 1 ' indicates that this order features a line from this location
            End If
        Next Header
    Else
    End If
Next rCell


With Application
    .ScreenUpdating = ScreenUpdateState
    .DisplayStatusBar = StatusBarState
    .Calculation = CalcState
    .EnableEvents = EventsState
    .DisplayPageBreaks = DisplayPageBreaksState
End With

Set S1 = Nothing
Set S2 = Nothing
Set Rng = Nothing
Set Rng2 = Nothing

MsgBox "Done in " & Timer - StartTime & " seconds.", vbOKOnly + vbInformation, "Procedure acheived"

End Sub