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

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

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
If cell.Value = 0 Then

Else

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

• Your best bet would be to read the range to an array do processing within the array and then output the array into the range. Doing anything with the sheet is time consuming for a computer of course. – 99moorem Jun 9 '15 at 12:34

A quick fix would be to change:

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

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


to

For Each cell In rng.Cells
If cell.Value <> 0 Then
Else
s2.Cells(cell.row, header.Column).Value = 1 ' indicates that this order features a line from this location
End If
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.

• Be sure to look at ChipsLetten's suggestions on completely re-working the function, as well as R3uK's With Application statements to really help improve the speed of your code. – FreeMan Jun 10 '15 at 16:42

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

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

For Each cell In rng.Cells
If cell.Value <> 0 Then
' indicates that this order features a line from this location
End If
End If
Next cell
With Application
.ScreenUpdating = True
End With
End Sub

• Excellent advice on both using .Find() or a dictionary. – FreeMan Jun 9 '15 at 15:28

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

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.

• Excellent points! "writing the data to an array before processing" is by far one of the best performance improvements in most cases – paul bica Jun 13 '15 at 2:17

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, _
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
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
Else
S2.Cells(rCell.Row, Header.Column).Value = 1 ' indicates that this order features a line from this location
End If
Else
End If
Next rCell

With Application
.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