VBA - 循环和低效的条件语句

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

有没有更好的方法可以做到这一点？我要循环遍历成千上万条记录，这需要很长时间。

编辑*

我终于有机会构建并尝试了这个代码。我遇到了一个无法解决的错误。当我到达循环中的第一个.autofilter时，就会出现运行时错误'424':对象所需。

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

- Pfantastic

---

使用 autofilter 和 specialcells(xlcelltypevisible)。 - nutsch

谢谢大家！最终我采用了Nutsch和Dan的综合方案。我甚至没有想过使用数组，而自动筛选器是天才的！我还计划尝试L42的解决方案，看看在处理大文件时是否有明显的性能提升。 - Pfantastic

很高兴你把它搞定了，L42的代码非常好，唯一我不太喜欢的是乘法运算，你能保证永远不会出现两个值得到相同的乘积吗？举个非常基本的例子，如果你在A列中有3，在C列中有4，那么这将与A列中的2和C列中的6给出相同的匹配。你无法区分它们。 - Dan Donoghue

我非常感谢你的帮助，丹 - 我也很担心乘法问题，这就是为什么我首先尝试了你的代码。但总共只有五个设施编号，它们彼此之间相差足够远，所以在与部门相乘时不可能得到相同的数字。但你是对的，那些列中选项更多（或数字位数较少）的人最好尝试使用自动筛选。 - Pfantastic

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

- nutsch

---

很棒的解决方案，希望你不介意我借鉴了你的代码并加入到我的解决方案中。 - Dan Donoghue

Answer 2

我只是在这里玩代码，这与您的代码相同但更短，数组比大量的if语句更易于管理：

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的连接创建vlookups，这样可以避免使用VBA。它必须在另一列中（即不能是自引用），但这会成为问题吗？

编辑：将Nutsch的想法与我的数组代码相结合（为了完整性保留旧代码）：

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

- Dan Donoghue

---

我已经编辑了我的原始帖子，您有没有可能提供额外的澄清？ - Pfantastic

Answer 3

试试这个：

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，其中包含您的结果值。
然后将您的范围值转移到一个2D数组RngArr中（它是自动的）并进行操作。
最后，将其转回到您的范围中。
我已经在实际代码中添加了注释，所以应该很容易跟随。 速度: 在我的机器上处理100k数据需要2.12秒。我认为它在速度方面可以与自动筛选相媲美。

- L42

Answer 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

- Greg