VBA - Loop and Inefficient If Statements
I wrote VBA code that is walkable, but it is time consuming and difficult to maintain. I use this to collapse multiple subordinate units into one department. Basically, I have two columns:
"A" - contains 5-digit object numbers
"C" - contains 5-digit department numbers
My code goes through each line and replaces the department numbers if the object and department match the condition:
Sub dept_loop()
Dim i As Long
Dim lRow As Long
lRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lRow
If Cells(i, "A") = 10000 And Cells(i, "C") = 11040 Then
Cells(i, "C") = 11000
ElseIf Cells(i, "A") = 10000 And Cells(i, "C") = 11040 Then
Cells(i, "C") = 11000
ElseIf Cells(i, "A") = 10000 And Cells(i, "C") = 11050 Then
Cells(i, "C") = 11000
ElseIf Cells(i, "A") = 10000 And Cells(i, "C") = 11060 Then
Cells(i, "C") = 11000
ElseIf Cells(i, "A") = 10000 And Cells(i, "C") = 11070 Then
Cells(i, "C") = 11000
ElseIf Cells(i, "A") = 21000 And Cells(i, "C") = 10120 Then
Cells(i, "C") = 10130
ElseIf Cells(i, "A") = 21000 And Cells(i, "C") = 10160 Then
Cells(i, "C") = 10050
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 11910 Then
Cells(i, "C") = 10000
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 11915 Then
Cells(i, "C") = 10000
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 14800 Then
Cells(i, "C") = 14000
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 14820 Then
Cells(i, "C") = 10000
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 15700 Then
Cells(i, "C") = 20040
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 20420 Then
Cells(i, "C") = 20400
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 20440 Then
Cells(i, "C") = 20400
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 21190 Then
Cells(i, "C") = 21000
ElseIf Cells(i, "A") = 22000 And Cells(i, "C") = 21195 Then
Cells(i, "C") = 21000
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 10760 Then
Cells(i, "C") = 10750
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11030 Then
Cells(i, "C") = 14000
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11360 Then
Cells(i, "C") = 11300
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11370 Then
Cells(i, "C") = 10000
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11600 Then
Cells(i, "C") = 11700
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11620 Then
Cells(i, "C") = 11700
ElseIf Cells(i, "A") = 23000 And Cells(i, "C") = 11660 Then
Cells(i, "C") = 11700
End If
Next i
End Sub
Is there a better way I could do this? I loop this over hundreds of thousands of entries and it takes forever ..
EDIT * I ββfinally got the chance to build this and try. I ran into an error that I can't figure out. I am getting a runtime error "424": an object is required as soon as I get to the first .autofilter in the loop.
@Nutsch or @Dan - any ideas?
Here's the new code I wrote:
Sub dept_loop ()
Dim BU As Variant, Dept As Variant, NewDept As Variant
Dim lRow As Long, lColumn As Long
'Array of facilities/business units (Roll From)
BU = Array(10000, 10000, 10000, 10000, 10000, 21000, 21000, 22000, _
22000, 21000, 21000, 23000, 23000, 22000, 21000, 21000, _
21000, 22000, 24000, 21000, 21000, 24000, 21000, 21000, _
23000, 22000, 21000, 22000, 21000, 25000, 23000, 25000, _
22000, 22000, 22000, 24000, 24000, 23000, 23000, 22000, _
22000, 24000, 23000, 23000, 25000, 25000, 23000, 25000, _
24000, 23000, 23000, 25000, 25000, 25000, 24000, 24000, _
25000, 25000, 21000, 21000, 21000, 22000, 22000, 23000, _
23000, 22000, 24000, 24000, 25000, 25000, 21000, 21000, _
21000, 21000, 22000, 22000, 22000, 22000, 23000, 23000, _
22000, 22000, 23000, 23000, 23000, 21000, 24000, 24000, _
24000, 24000, 25000, 22000, 25000, 25000, 25000, 23000, _
24000, 25000, 22000, 21000, 22000, 23000, 24000, 25000, _
21000, 22000, 21000, 22000, 23000, 24000, 25000, 22000)
'Array of departments (Roll From)
Dept = Array(11040, 11040, 11050, 11060, 11070, 10120, 10160, 10120, _
10160, 10760, 11030, 10120, 10160, 10760, 11360, 11370, _
11371, 11030, 10120, 11570, 11600, 10160, 11620, 11660, _
10760, 11360, 11910, 11370, 11915, 10120, 11030, 10160, _
11600, 11620, 11660, 10700, 10760, 11360, 11370, 11910, _
11915, 11030, 11600, 11620, 10700, 10701, 11660, 10760, _
11370, 11910, 11915, 11030, 11360, 11370, 11910, 11915, _
11910, 11915, 14800, 14820, 14840, 14800, 14820, 14800, _
14820, 15700, 14800, 14820, 14800, 14820, 20420, 20440, _
21190, 21195, 20420, 20440, 21190, 21195, 20420, 20440, _
21800, 21820, 21155, 21190, 21195, 23250, 20440, 21155, _
21190, 21195, 20440, 23250, 21155, 21190, 21195, 23250, _
23250, 23250, 26500, 28950, 28950, 28950, 28950, 28950, _
39011, 39011, 46100, 46100, 46100, 46100, 46100, 88220)
'Array of new departments (Roll To)
NewDept = Array(11000, 11000, 11000, 11000, 11000, 10130, 10050, 10130, _
10050, 10750, 14000, 10130, 10050, 10750, 11300, 10000, _
10130, 14000, 10130, 10000, 11700, 10050, 11700, 11700, _
10750, 11300, 10000, 10000, 10000, 10130, 14000, 10050, _
11700, 11700, 11700, 10000, 10750, 11300, 10000, 10000, _
10000, 14000, 11700, 11700, 10000, 10000, 11700, 10750, _
10000, 10000, 10000, 14000, 11300, 10000, 10000, 10000, _
10000, 10000, 14000, 10000, 10000, 14000, 10000, 14000, _
10000, 20040, 14000, 10000, 14000, 10000, 20400, 20400, _
21000, 21000, 20400, 20400, 21000, 21000, 20400, 20400, _
25040, 24400, 21150, 21000, 21000, 23200, 20420, 21150, _
21000, 21000, 20420, 23200, 21150, 21000, 21000, 23200, _
23200, 23200, 26700, 22000, 22000, 22000, 22000, 22000, _
39000, 39000, 10000, 10000, 10000, 10000, 10000, 10000)
'Application.ScreenUpdating = False
lRow = range("A" & Rows.Count).End(xlUp).Row
lColumn = Cells(1, Columns.Count).End(xlToLeft).Column
With range(Cells(1, 1).Address, Cells(lRow, lColumn).Address).AutoFilter
For x = LBound(BU) To UBound(BU)
.AutoFilter Field:=3, Criteria1:=Dept, Operator:=xlFilterValues
.AutoFilter Field:=1, Criteria1:=BU
.AutoFilter.Columns(3).Resize(.Rows.Count - 1).Offset(1). _
SpecialCells(xlCellTypeVisible).Value = NewDept
Next
End With
End Sub
FINAL EDIT * I ββfinished working on my code, but I also tried the L42 solution which turned out to be much faster than autofilter. The L42 code is what I end up using. Thank!
source to share
Try the following:
Sub conscious()
Dim MulArr, ResArr, RngArr, pos
Dim i As Long, lrow As Long, x As Long
' Multiply your value1 and value2
MulArr = Array(110400000, 114040000, 110500000, 110600000, 110700000, _
212520000, 213360000, 262020000, 262130000, 325600000, _
326040000, 345400000, 449240000, 449680000, 466180000, _
466290000, 247480000, 253690000, 261280000, 261510000, _
266800000, 267260000, 268180000)
' Result array
ResArr = Array(11000, 11000, 11000, 11000, 11000, 10130, 10050, 10000, 10000, 14000, _
10000, 20040, 20400, 20400, 21000, 21000, 10750, 14000, 11300, 10000, _
11700, 11700, 11700)
With Sheets("Sheet1") ' Try to be explicit always
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
RngArr = .Range("A1:C" & lrow) ' Use 2D array
For i = LBound(RngArr, 1) To UBound(RngArr, 1) ' Manipulate the array
x = RngArr(i, 1) * RngArr(i, 3): pos = Application.Match(x, MulArr, 0)
If Not IsError(pos) Then RngArr(i, 3) = Application.Index(ResArr, pos)
Next
.Range("A1:C" & lrow) = RngArr ' Return the array to Range
End With
End Sub
First, you need to create a new array MulArr
that is the multiplication of your values.
Create a second array ResArr
that contains your resulting values.
Then pass your range value in a 2D array RngArr
(it's automatic) and manipulate it.
Finally, move it back to your range.
I have added comments to the actual code, so it shouldn't be difficult.
Speed: . It took 2.12 seconds on my machine with 100k of data. I think it can compete with the autofilter in terms of speed.
source to share
This is how I would go about it, using an autofilter to replace the line blocks right away and disable screen refresh to cut down on processing time.
Dim lRow As Long
lRow = Cells(Rows.Count, "A").End(xlUp).Row
application.screenupdating=false
With Range("A1:C" & lRow)
.AutoFilter
.AutoFilter Field:=3, Criteria1:=Array( _
"11040", "11050", "11060", "11070"), Operator:=xlFilterValues
.AutoFilter Field:=1, Criteria1:="10000"
.Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Value = 11000
.AutoFilter Field:=3, Criteria1:="10120", Operator:=xlFilterValues
.AutoFilter Field:=1, Criteria1:="21000"
.Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Value = 10130
.AutoFilter Field:=3, Criteria1:="10160", Operator:=xlFilterValues
.Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Value = 10050
'etc., etc.
End With
application.screenupdating=true
source to share
Just playing around with the code here, this is the same as your code, but in short, arrays are more manageable than large lists of ifs:
Sub dept_loop()
Dim i As Long, CellA As Variant, CellC As Variant, NewCellC As Variant
CellA = Array(10000, 10000, 10000, 10000, 10000, 21000, 21000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 23000, 23000, 23000, 23000, 23000, 23000, 23000)
CellB = Array(11040, 11404, 11050, 11060, 11070, 10120, 10160, 11910, 11915, 14800, 14820, 15700, 20420, 20440, 21190, 21195, 10760, 11030, 11360, 11370, 11600, 11620, 11660)
NewCellC = Array(11000, 11000, 11000, 11000, 11000, 10130, 10050, 10000, 10000, 14000, 10000, 20040, 20400, 20400, 21000, 21000, 10750, 14000, 11300, 10000, 11700, 11700, 11700)
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
For X = LBound(CellA) To UBound(CellA)
If Cells(i, 1).text = CellA(X) And Cells(i, 3).text = CellC(X) Then
Cells(i, 3).Formula = NewCellC(X)
Exit For
End If
Next
Next
End Sub
As for the best way to do this, I am probably leaning towards no VBA solution, using a matrix in a hidden sheet and creating vlookups based on the concatenation of cells A and C. It must be in another column (i.e. it cannot be self-relational ), but would that be a problem?
Edit: Combined Nutsch awesome idea with my Array code (for completeness left old code above):
Sub dept_loop()
CellA As Variant, CellC As Variant, NewCellC As Variant
CellA = Array(10000, 10000, 10000, 10000, 10000, 21000, 21000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 22000, 23000, 23000, 23000, 23000, 23000, 23000, 23000)
CellB = Array(11040, 11404, 11050, 11060, 11070, 10120, 10160, 11910, 11915, 14800, 14820, 15700, 20420, 20440, 21190, 21195, 10760, 11030, 11360, 11370, 11600, 11620, 11660)
NewCellC = Array(11000, 11000, 11000, 11000, 11000, 10130, 10050, 10000, 10000, 14000, 10000, 20040, 20400, 20400, 21000, 21000, 10750, 14000, 11300, 10000, 11700, 11700, 11700)
Application.ScreenUpdating = False
With Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)
.AutoFilter
For X = LBound(CellA) To UBound(CellA)
.AutoFilter Field:=3, Criteria1:=CellC, Operator:=xlFilterValues
.AutoFilter Field:=1, Criteria1:=CellA
.Columns(3).Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Value = NewCellC
Next
End With
Application.ScreenUpdating = True
End Sub
source to share
Interoperability with Excel is relatively expensive. Try to read the entire dataset in memory, manipulate it there, and then write the whole new dataset.
If the dataset, if it's too big to fit into RAM, you can do it in chunks.
Dim Arr() As Variant
Arr = Range("A1:C100000")
For i = 1 to 100000
If Arr(i, 1) = 10000 And Arr(i, 3) = 11040 Then
.
.
.
Next
Range("A1:C100000") = Arr
source to share