HiveBrain v1.2.0
Get Started
← Back to all entries
patternMinor

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

Submitted by: @import:stackexchange-codereview··
0
Viewed 0 times
locationsorderfocusarrangeslooksanddata

Problem

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

Solution

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.

Code Snippets

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
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

Context

StackExchange Code Review Q#93091, answer score: 8

Revisions (0)

No revisions yet.