VBA - Loop and Inefficient If Statements

Question

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!

Thanks all! I ended up using the combined solution of Nutsch and Dan. I hadn't even thought about using an array, and the autofilter is genius! I'm also planning on trying L42's solution to see if there is a noticable increase in performance with large files. — Pfantastic
– Pfantastic, Commented Jun 4, 2015 at 15:24
Glad you got it working, L42's code is very good, the only thing I am not keen on is multiplying values, are you guaranteed that you will never get two values that give the same multiplied number? for a very basic example if you had 3 in Col A and 4 in Col C that would give a match the same as 2 in Col A and 6 in Col C. You would have no way to differentiate them. — Dan Donoghue
– Dan Donoghue, Commented Jun 4, 2015 at 21:52
I really appreciate your help Dan - I was worried about the multiplication as well, which is why I gave your code a shot first. But there are only five facility numbers total and they are far enough apart that there is no chance in getting the same number when multiplying with the departments. But you're right, someone with more options (or numbers with fewer digits) in their columns might be better off trying to autofilter. — Pfantastic
– Pfantastic, Commented Jun 4, 2015 at 22:19

nutsch · Accepted Answer · 2015-06-03 23:12:31Z

5

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

answered Jun 3, 2015 at 23:12

nutsch

5,9622 gold badges23 silver badges36 bronze badges

Sign up to request clarification or add additional context in comments.

1 Comment

Dan Donoghue Over a year ago

Great solution, hope you don't mind I poached your code and added to my solution

L42 · Accepted Answer · 2015-06-04 01:02:10Z

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.

Dan Donoghue · Accepted Answer · 2015-06-03 23:28:54Z

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

I've edited my original post, is there any chance you can provide any additional clarification?

Greg · Accepted Answer · 2015-06-04 13:40:40Z

0

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

edited Jun 4, 2015 at 13:40

answered Jun 3, 2015 at 23:07

Greg

4264 silver badges13 bronze badges

Collectives™ on Stack Overflow

VBA - Loop and Inefficient If Statements

4 Answers 4

1 Comment

Comments

1 Comment

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

4 Answers 4

1 Comment

Comments

1 Comment

Comments

Your Answer

Sign up or log in

Post as a guest

Related