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

End Sub

最终编辑* 我最终得到了我的代码，但我也尝试了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

Answer 2

只是在这里玩代码，这与你的代码相同但更短，数组比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的精彩想法与我的数组代码相结合（上面的旧代码是完整性的）：

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

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秒。我认为它可以在速度方面与自动过滤器相媲美。

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

VBA - 循环和低效率如果陈述

4 个答案: