我编写的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——有什么想法吗？
这是我编写的新代码:
子 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 的代码是我最终将使用的。谢谢!
最佳答案
这是我的做法，使用自动过滤器一次替换行 block 并禁用屏幕更新以减少处理时间。
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
关于VBA - 循环和低效的 If 语句，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/30632266/