如何优化在大量记录上运行的宏？

Question

我想出了一个宏来针对员工填充超级经理。我无法针对大量数据和 Excel 挂起执行此宏。我认为这段代码没有完全优化。

一些要求和先决条件：

1. 经理 ID 列将是第一列，即 A 列，员工 ID 列是第二列，即工作表中的 B 列。
2. 表 1 中不会填充超级经理，即表 1 中不应存在任何超级经理的记录，除了他们的 ID 映射到其他员工的经理 ID
3. 超级经理将按照与附表中相同的顺序填充到表 2 中，即。超级经理 ID |超级经理姓名|需要任何额外的数据字段。
4. 满足先决条件后，请单击“宏”按钮并运行名为：Main_Function_SuperManager 的宏。
5. 超级经理的详细信息将分别列在表 1 的 S 列和 T 列中。

这是我的宏：

Option Explicit
Sub Main_Function_SuperManager()
Dim i, re
Root_Parent
Replace
Replace_Name
i = 1
    While Cells(i, 22) <> ""

         Cells(i, 22) = ""
         Cells(i, 23) = ""
         i = i + 1

    Wend
End Sub
Sub Root_Parent()
    Dim i, re, k
    i = 2
    While Cells(i, 1) <> ""
        Set re = Range("B:B").Find(Cells(i, 1))
        If re Is Nothing Then
            Set re = Range("V:V").Find(Cells(i, 1))
            If re Is Nothing Then
                k = k + 1
                Cells(k, 22) = Cells(i, 1)
                Cells(k, 23) = "Super Manager"
                findchild Cells(k, 22).Value, k
            End If
        End If
        i = i + 1
    Wend
End Sub
Sub findchild(parent, ByRef k)
 Dim i, s, re
 i = 1
    While Cells(i, 2) <> ""
    s = i
        Do
            Set re = Range("B:B").Find(Cells(s, 1))
            If re Is Nothing Then
                If Cells(s, 1) = parent Then
                k = k + 1
                Cells(k, 22) = Cells(i, 2)
                Cells(k, 23) = Cells(s, 1)
                End If
                Exit Do
            Else
                s = re.Row
            End If
        Loop
        i = i + 1
    Wend
End Sub

Sub Replace()
    Dim i, re, s
    i = 2
    While Cells(i, 22) <> ""
        Set re = Range("B:B").Find(Cells(i, 22))
        If re Is Nothing Then
        Cells(10, 24) = ""
        Else
         s = re.Row
         Cells(s, 19) = Cells(i, 23)
        End If
        i = i + 1

    Wend
End Sub

Sub Replace_Name()
    Dim i, re, s
    i = 2
    While Cells(i, 19) <> ""
        Set re = Worksheets("Sheet2").Range("A:A").Find(Cells(i, 19))
        If re Is Nothing Then
        Cells(10, 24) = ""
        Else
         s = re.Row
         Cells(i, 20) = Worksheets("Sheet2").Cells(s, 2)
        End If
        i = i + 1

    Wend
End Sub

此代码帮助我解析大量数据并将最高级别的根节点列出到子节点和大子节点。

我的数据结构如下：

MANAGER ID|EMP ID|NAME|GRADE|MANAGER|<some other fields>|SUPER MANAGER ID|SUPER MANAGER NAME

非常期待优化此代码的提示，以便我可以在大型数据集上执行该功能。

本质上，我希望用它们各自的最高级别根节点填充子节点，以便所有子节点都有一个根级别数据/父节点映射到它们。

Answer 1

此代码中的主要拖累是在工作表中不断读取和写入。如果您使用变量中的数据，代码将非常快。事实上，像您这样的代码在以这种方式工作时应该在几秒钟（或更短）内完成。

我起草了一个示例，灵感来自您代码中的一个子程序，它可能无法“开箱即用”，因为我不完全理解您的数据结构，但最重要的一点是：获取所有数据只从工作簿中取出一次，然后将其放回那里一次（这是在 3 * 行中完成的）。逻辑运算应该在内存中完成（数据存储在变量中）。

Sub Replace()
    Dim i, re, s, row_num, col_num, data_initial(), data_final()
    Dim WS_1 As Worksheet

    'defines the worksheet object
    Set WS_1 = ThisWorkbook.Worksheets("Sheet1")

    'get where do the data range begins and ends
    row_num = WS_1.Cells(1, 1).End(xlDown).Row
    col_num = WS_1.Cells(1, 1).End(xlToRight).Row

    '***dump the data from the worksheet to memory all in once
    data_initial = WS_1.Cells(1, 1).Resize(Row - 1, col).Value

    'create a blank matrix where the output will be placed
    ReDim data_final(LBound(data_initial, 1) To UBound(data_initial, 1), LBound(data_initial, 2) To UBound(data_initial, 2))

    'you do your work whith the data, this part may not be coherent since I dont understand your data very well
    i = 1
    While i <= UBound(data_initial, 1)
        If data_initial(i, 22) = "" Then
            data_final(i, 24) = ""
        Else
            s = 1
            Do Until data_initial(i, 2) = data_initial(i, 22)
                s = s + 1
            Loop

            data_final(i, 24) = data_initial(i, 23)

            i = i + 1
    Wend

    '***dump the data into the worksheet (again, just once)
    WS_1.Cells(1, 1).Resize(LBound(data_initial, 1) To UBound(data_initial, 1), LBound(data_initial, 2) To UBound(data_initial, 2)).Value = data_final

End Sub