patternMinor
Looks at order data and arranges it to focus on order locations
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
My code works, but it works very slow. So advice on how to make it faster would be appreciated.
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 SubSolution
A quick fix would be to change:
to
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
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 cellto
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 cellThat 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 cellFor 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 cellContext
StackExchange Code Review Q#93091, answer score: 8
Revisions (0)
No revisions yet.