在图遍历中添加/复印超过1000张

对不起，如果这有点长。

我被要求列出所有公司员工的名单，创build一个关联员工和他们的经理的层次结构，然后创build一个接口，该pipe理员需要一个ID，并为每个员工输出一个新的工作簿（最多3个）级别），其中包含有关员工在模板摘要中replace占位符的信息。

我目前正在成功地创build和填充有雇员ID作为关键字和Person对象作为数据的节点的有向图。 我遇到的问题是当我尝试在遍历图表方法上扩展到新工作簿中单独的员工汇总表时。

我编写了下面的代码来创build工作表，如果在给定的主pipe下面只有500名员工，那么这个工作表就可以完成任务 – 但是，有一些主pipe可以有2000名员工在三级深度。 有了这些主pipe，程序将在完全冻结或崩溃之前运行大约10分钟，而且由于我正在打印到即时屏幕，因此我可以看到每个员工似乎都要以更慢，更慢的速度创build每个表单。

我知道这是关于复制/添加工作表的事情，因为在遍历中仅仅执行de-queue-d节点的Person数据的Debug.Print，而不是添加工作表将在〜5秒内运行任何主pipe的总数，无论他们下面有200或2000名员工。

我想知道是否有办法复制/添加不会造成这个问题的表单，但是甚至更多的是，我觉得我被要求把主pipe下的所有员工放在同一个工作簿中将会有2000张 – 看起来好像使用该程序的人随后滚动1,000张单张find他们每次需要查看的员工是不可行的。 所以，我也想弄清楚如何为每个父节点添加一个工作簿，然后让他们的所有孩子进入特定的工作簿 – 我无法弄清楚如何跟踪哪个工作簿进入，因为只有级别上的员工分离。

以下是图遍历的代码：

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