Reputation: 103
I have written VBA code that is passable, but it takes a long time and is difficult to upkeep. I use this to roll up several sub departments into a single department. Basically, I have two columns:
"A" - contains 5 digit facility numbers
"C" - contains 5 digit department numbers
My code loops through each row and replaces department numbers if the facility 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 be doing this? I loop this through hundreds of thousands of records and it takes forever..
EDIT* I've finally had a chance to build this out and give it a try. I've encountered an error that I cannot figure out. I'm getting a runtime error '424': Object required as soon as I get to the first .autofilter in the loop.
@Nutsch or @Dan -- any ideas?
Here is the new code I've written:
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 ended up getting my code to work, but I also tried L42's solution I found it was much faster than the autofiltering. L42's code is what I will end up using. Thanks!
Upvotes: 3
Views: 212
Reputation: 426
Interacting with Excel is relatively expensive. Try reading the entire dataset into memory, manipulating it there, and then writing the entire new dataset back.
If the dataset if too big to fit into RAM, you could do this in pieces.
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
Upvotes: 0
Reputation: 19737
Try this:
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
which is the multiplication of your values.
Create a second array ResArr
which contains your resulting values.
Then transfer your range value in a 2D array RngArr
(it is automatic) and manipulate it.
And then finally, transfer it back to your range.
I have added comments in the actual code so it shouldn't be hard to follow.
Speed: This took 2.12 secs in my machine dealing with 100k data. I think it can rival the autofilter in terms of speed.
Upvotes: 1
Reputation: 6216
Just playing around with the code here, this is the same as your code but shorter, Arrays are more manageable than big 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 a better way to do this, I would probably lean towards a none VBA solution using a matrix on a hidden sheet and creating vlookups based on the concatenation of cell A and C. It would have to be in another column (ie it can't be self referential) but would that be a problem?
Edit: Combined Nutsch's awesome idea with my Array code (Left old code above for completeness):
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
Upvotes: 1
Reputation: 5962
Here's how I would do it, using autofilter to replace blocks of lines at once and disabling the screen update to reduce 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
Upvotes: 5