VBA – 循环和低效如果语句
我已经写了可以通过的VBA代码，但这需要很长时间，难以维护。 我用这个来把几个子部门整合成一个部门。 基本上我有两列：
“A” – 包含5位数的设施号码
“C” – 包含5位数的部门号码
我的代码循环遍历每一行，并replace部门号码，如果设施和部门符合条件：
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 有没有更好的办法可以做到这一点？ 我循环这成千上万的logging，这需要永远..
编辑*我终于有机会build立这个，试试看。 我遇到了一个我找不到的错误。 我得到一个运行时错误“424”：只要我到达循环中的第一个.autofilter所需的对象。
@Nutsch或@丹 – 任何想法？
这是我写的新代码：
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的解决scheme，我发现它比自动过滤快得多。 L42的代码是我最终会使用的。 谢谢！
尝试这个：
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
首先，你需要创build一个新的数组MulArr ，它是你的值的乘积。
创build第二个包含结果值的数组ResArr 。
然后在二维数组RngArr （它是自动的）中传输范围值并对其进行处理。
最后，把它传回你的范围。
我已经在实际的代码中添加了注释，所以不应该很难遵循。
速度：我的机器花了2.12秒处理100k数据。 我认为它可以在速度上与autofilter相媲美。
以下是我如何做，使用自动filter来replace块的行，并禁用屏幕更新，以减less处理时间。
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
只是在这里玩弄代码，这和你的代码一样，但更短，数组比ifs的大列表更易于pipe理：
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
至于更好的方法，我可能会倾向于一个没有VBA的解决scheme，在隐藏的表格上使用一个matrix，并基于单元格A和C的连接创buildvlookups。它必须位于另一列（即它可以不是自我指涉），但这会是一个问题吗？
编辑：与我的arrays代码结合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
与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