Vba 在图形遍历中添加/复制1000多张图纸

抱歉，如果这有点长

我被要求列出所有公司员工的名单，创建一个将员工和他们的经理联系起来的层次结构，然后制作一个界面，该界面采用主管ID，并输出一个新的工作簿，其中每个员工都有单独的工作表（最多3级）包含有关替换模板摘要中占位符的员工的信息

我目前正在成功创建并填充一个有向图，其中的节点以员工ID为键，以Person对象为数据。 我遇到的问题是，当我试图扩展遍历图方法，以便在新工作簿中分离员工汇总表时

我编写了下面的代码来创建工作表，如果在给定主管之下只有约500名员工，则该工作表可以完成任务–但是，某些主管的3级深度内最多可以有2000名员工。有了这些主管，程序将运行大约10分钟，然后完全冻结或崩溃，因为我正在即时屏幕上打印，我可以看到它似乎以越来越慢的速度传到每个员工/创建每张工作表

我知道这与复制/添加工作表有关，因为只需进行调试。在遍历中打印de-queue-d节点的人员数据，而不是添加工作表，对于任何主管而言，无论其下方是否有200或2000名员工，总共只需约5秒

我想知道是否有一种复制/添加工作表的方法不会造成这种问题，但更重要的是，我觉得奇怪的是，如果有2000张工作表，我被要求将主管领导下的所有员工都放在同一个工作簿中——对于使用该程序的人来说，滚动1000多张工作表以找到他们每次都需要查看的员工似乎根本不可行。因此，我还试图找出如何为某一级别上的每个父节点添加工作簿，然后让其所有子节点都进入该特定工作簿——我不知道如何跟踪它将进入哪个工作簿，因为在不同级别之间只有员工分离

以下是图形遍历的代码：

Sub TraverseCreateSheets(rootS As String)

Dim wb As Workbook, newWb As Workbook
Set wb = ThisWorkbook
'the below sheet is the template sheet that I am copying to fill out
Dim managementSumTemplate As Worksheet
Set managementSumTemplate = wb.Sheets("Management Summary")


Dim maxDepth As Integer, curDepth As Integer
maxDepth = 3
curDepth = 0


Dim root As node
Set root = pNodeList.Item(rootS)
Dim visited As Object
Set visited = CreateObject("Scripting.Dictionary")

Dim queue As Object
Set queue = CreateObject("System.Collections.Queue")
queue.Enqueue root

Dim nullNode As node
Set nullNode = New node
nullNode.Key = "NULLNODE"
queue.Enqueue nullNode

Workbooks.Add
Set newWb = ActiveWorkbook

Application.ScreenUpdating = False
Application.DisplayStatusBar = False

'implementation of breadth first search using a queue
'because I had to be able to limit the levels correctly
Dim currentNode As node
Do While queue.Count <> 0
    Set currentNode = queue.Dequeue()

    If Not visited.Exists(currentNode.Key) Then


        If currentNode.Key = "NULLNODE" Then
            curDepth = curDepth + 1
            If curDepth > maxDepth Then
                Exit Do
            End If

            queue.Enqueue nullNode
            Dim peekNode As node
            Set peekNode = queue.Peek
            If peekNode.Key = "NULLNODE" Then
                Exit Do
            End If
        End If

        If Not currentNode.Key = "NULLNODE" Then
            visited.Add currentNode.Key, currentNode


            Dim curPer As Person
            Set curPer = currentNode.Data
            'just doing the below debug statement without any sheet additions can make entire traversal only take 5 seconds 
            Debug.Print "ID: " & currentNode.Key & " Name: " & curPer.Name & _
                " Location: " & curPer.Location & " PyrHead: " & curPer.PyrHead & _
                " Job: " & curPer.Job & " Job Entry: " & curPer.JobEntry & " Time in Pos: " & curPer.TimeInPos & _
                " Hire Date: " & curPer.HireDate & " Supervisor ID " & curPer.SupervisorID & " Supervisor " & curPer.Supervisor


            'adding the worksheet here, since I am copying the 
            'sheet I have to rename
            Dim reportSheet As Worksheet
            managementSumTemplate.Copy Before:=newWb.Sheets(1)
            Set reportSheet = newWb.Worksheets("Management Summary")
            reportSheet.Name = currentNode.Key

            reportSheet.Range("A7").Value = curPer.Location
            reportSheet.Range("A8").Value = curPer.PyrHead
            reportSheet.Range("B7").Value = curPer.Name
            reportSheet.Range("B8").Value = curPer.Job
            reportSheet.Range("B10").Value = curPer.HireDate
            reportSheet.Range("B11").Value = curPer.JobEntry
            reportSheet.Range("B12").Value = curPer.TimeInPos



            For Each neighbor In currentNode.Neighbors
                queue.Enqueue neighbor
            Next neighbor
        End If
    End If

Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True

End Sub

子遍历创建工作表（根作为字符串）
将wb设置为工作簿，将新wb设置为工作簿
设置wb=ThisWorkbook
'下表是我正在复制以填写的模板表
将模板设置为工作表
设置managementSumTemplate=wb.Sheets（“管理摘要”）
Dim maxDepth为整数，curDepth为整数
最大深度=3
curDepth=0
将根作为节点
Set root=pNodeList.Item（根）
作为对象访问的对象
Set visted=CreateObject（“Scripting.Dictionary”）
将队列设置为对象
Set queue=CreateObject（“System.Collections.queue”）
列队根
将nullNode设置为节点
Set nullNode=新节点
nullNode.Key=“nullNode”
queue.Enqueue nullNode
工作手册。添加
设置newWb=ActiveWorkbook
Application.ScreenUpdating=False
Application.DisplayStatusBar=False
'使用队列实现广度优先搜索
“因为我必须能够正确限制水平
Dim currentNode作为节点
排队时执行此操作。计数0
Set currentNode=queue.Dequeue（）
如果未访问.Exists（currentNode.Key），则
如果currentNode.Key=“NULLNODE”，则
curDepth=curDepth+1
如果curDepth>maxDepth，则
退出Do
如果结束
queue.Enqueue nullNode
将节点定义为节点
设置Peek节点=queue.Peek
如果peekNode.Key=“NULLNODE”，则
退出Do
如果结束
如果结束
如果不是currentNode.Key=“NULLNODE”，则
已访问。添加currentNode.Key，currentNode
人影
设置curPer=currentNode.Data
'只需执行下面的调试语句而不添加任何工作表，整个遍历只需5秒钟
Debug.Print“ID:¤tNode.Key&“Name:&curPer.Name&”_
“位置：”&curPer.Location&“PyrHead:”&curPer.PyrHead&_
“作业：”&curPer.Job&“作业条目：”&curPer.JobEntry&“Pos中的时间：”&curPer.TimeInPos&_
“雇用日期：”&curPer.HireDate&“主管ID”&curPer.SupervisorID&“主管”与curPer.Supervisor
'在此处添加工作表，因为我正在复制
“我必须重新命名
作为工作表的Dim报告表
managementSumTemplate.Copy Before:=新建WB.Sheets（1）
Set reportSheet=newWb.工作表（“管理摘要”）
reportSheet.Name=currentNode.Key
报告表范围（“A7”）。值=电流位置
报告表。范围（“A8”）。值=curPer.PyrHead
reportSheet.Range（“B7”）.Value=curPer.Name
reportSheet.Range（“B8”）.Value=curPer.Job
报告表。范围（“B10”）。值=curPer.HireDate
reportSheet.Range（“B11”）。值=curPer.JobEntry
reportSheet.Range（“B12”）。值=curPer.TimeInPos
对于currentNode.Neights中的每个邻居
排队，让邻居排队
下一个邻居
如果结束
如果结束
环
Application.ScreenUpdating=True
Application.DisplayStatusBar=True
端接头

最好的办法是去找你的老板，告诉他你有更好的办法。有一个用于视图的工作表和一个用于模型的工作表。如果你可以查询一个用作数据库的外部工作簿，那就更好了。是的，看来我得让人们相信这是一个更好的选择。谢谢。最好的办法就是去找你的老板，告诉他你有更好的办法。有一个用于视图的工作表和一个用于模型的工作表。如果你能合作的话会更好