VBA - 循环和低效的If语句

Question

我已经编写了可以通行的VBA代码,但是它需要很长时间并且难以维护.我用它将几个子部门汇总到一个部门.基本上,我有两列:

"A" - 包含5位数的设施号

"C" - 包含5位数的部门编号

我的代码循环遍历每一行,如果设施和部门符合条件,则替换部门编号:

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

有没有更好的方法可以做到这一点？我通过成千上万的记录循环它,它需要永远..

编辑*我终于有机会建立这个并尝试一下.我遇到了一个我无法弄清楚的错误.我得到一个运行时错误'424':当我到达循环中的第一个.autofilter时,需要对象.

@Nutsch或@Dan - 有什么想法吗？

这是我写的新代码:

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

结束子

最终编辑*我最终得到了我的代码,但我也尝试了L42的解决方案,我发现它比自动过滤要快得多.L42的代码就是我最终会使用的代码.谢谢!

Answer 1

以下是我将如何操作,使用自动过滤器一次替换行块并禁用屏幕更新以减少处理时间.

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