VBA - 循环和低效的 If 语句答案

【问题标题】：VBA - Loop and Inefficient If StatementsVBA - 循环和低效的 If 语句
【发布时间】：2015-06-03 22:58:11
【问题描述】：

我编写的 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 -- 有什么想法吗？

这是我写的新代码：

子部门循环（）

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 的代码。谢谢！

【问题讨论】：

使用autofilter 和specialcells(xlcelltypevisible)
谢谢大家！我最终使用了 Nutsch 和 Dan 的组合解决方案。我什至没有考虑过使用数组，而自动过滤器是天才！我还计划尝试 L42 的解决方案，看看大文件的性能是否有显着提升。
很高兴你成功了，L42 的代码非常好，我唯一不喜欢的就是乘法，你能保证你永远不会得到两个得到相同乘数的值吗？举一个非常基本的例子，如果你在 Col A 中有 3 个，在 Col C 中有 4 个，这将给出与 Col A 中的 2 和 Col C 中的 6 相同的匹配。你将无法区分它们。
我非常感谢你的帮助 Dan - 我也担心乘法，这就是为什么我先试一试你的代码。但是总共只有五个设施编号，并且它们之间的距离足够远，以至于在与部门相乘时没有机会得到相同的编号。但你是对的，在他们的列中有更多选项（或数字更少的数字）的人可能最好尝试自动过滤。

标签： vba excel

【解决方案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

【讨论】：

很好的解决方案，希望你不介意我偷走了你的代码并添加到我的解决方案中

【解决方案2】：

试试这个：

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

首先，您需要创建一个新数组 MulArr，它是您的值的乘积。
创建第二个数组 ResArr，其中包含您的结果值。
然后将您的范围值传输到二维数组RngArr（它是自动的）并对其进行操作。
最后，将其转移回您的射程。
我在实际代码中添加了 cmets，所以应该不难理解。

速度：我的机器处理 100k 数据需要 2.12 秒。我认为它在速度方面可以与自动过滤器相媲美。

【讨论】：

【解决方案3】：

只是在这里玩一下代码，这与您的代码相同，但更短，数组比 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

至于更好的方法来做到这一点，我可能会倾向于使用隐藏表上的矩阵并基于单元格 A 和 C 的串联创建 vlookup 的非 VBA 解决方案。它必须在另一列中（即它不能是自引用的）但这会是一个问题吗？

编辑：将 Nutsch 的绝妙想法与我的 Array 代码相结合（为了完整起见，将旧代码保留在上面）：

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

【讨论】：

我已经编辑了我的原始帖子，您是否有机会提供任何额外的说明？

【解决方案4】：

与 Excel 交互的成本相对较高。尝试将整个数据集读入内存，在那里对其进行操作，然后将整个新数据集写回。

如果数据集太大而无法放入 RAM，您可以分段进行。

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

【讨论】：