创建新工作表时从模块内部更新工作簿的内部工作表列表

Question

附加的代码都位于excel VBAProject的模块中。代码将扫描所有现有的工作表并检索数据，对其进行分类，甚至在找到子组件时创建新的工作表。

问题是： （1）在重新运行之前，它不会在新创建的工作表上执行任何任务。我认为这个问题与强制工作簿在每次创建新工作表时更新其工作表列表有关。 （2）该例程似乎在运行结束时添加了一个工作表，该工作表与用于创建新工作表的标准不匹配。 （即子程序集编号以772,993,995,996或997开头）

请注意，在部分中存在禁用的代码，以便可以跟踪我尝试过的一些事物，例如 - “ThisWorkbook.Save，等...

任何帮助，将不胜感激，我跑出来的头发:)

代码：

Sub LoopThroughSheets() 

Dim ws As Worksheet 
Dim WS_Count As Integer 
Dim ws_iCount As Integer 
Dim i As Variant 
Dim myBOMValue As Variant 
Dim iRow As Long 
Dim iRowValue As Variant 
Dim iRowL As Variant 
Dim iCountA As Integer 
Dim sShtName As String 
For Each ws In ActiveWorkbook.Worksheets 
    On Error Resume Next 'Will continue if an error results 
    If Not ws.Name = "Main" And Not ws.Name = "BOM" Then 
     myBOMValue = ws.Name 
     Sheets(ws.Name).Activate 
     ' store sub-assembly name at cell C1 of active worksheet 
     Range("C1").Value = ws.Name 
     ' Cmd for system and application to do non-macro related events 
     DoEvents 
' Begin FishBowl Query for sub-assembly parts 
      With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array(Array("ODBC;DSN=Fishbowl;Driver=Firebird/InterBase(r) driver;Dbname=###.###.###.###:C:\Fishbowl2\database\data\$$$$.FDB;CHARSET=NONE;;UID=GO"), Array("NE;Client=C:\Program Files\Fishbowl\odbc\fbclient32.dll;")), Destination:=Range("$A$2")).QueryTable 
       ' @@ QueryTable commands START 
       ' select BOM and retrieve data 
       .CommandText = Array("SELECT BOM.NUM, PART.NUM, PART.DESCRIPTION, BOMITEM.QUANTITY" & Chr(13) & Chr(10) & "FROM BOMITEM" & Chr(13) & Chr(10) & "INNER JOIN BOM" & Chr(13) & Chr(10) & "ON BOMITEM.BOMID = BOM.ID" & Chr(13) & Chr(10) & "INNER JOIN PART" & Chr(13) & Chr(10) & "ON PART.ID = BOMITEM.PARTID" & Chr(13) & Chr(10) & "WHERE BOM.NUM Like '%" & myBOMValue & "%'" & Chr(13) & Chr(10) & "Order BY Part.Num") 
       .RowNumbers = False 
       .FillAdjacentFormulas = False 
       .PreserveFormatting = True 
       .RefreshOnFileOpen = False 
       .BackgroundQuery = False 
       .RefreshStyle = xlInsertDeleteCells 
       .SavePassword = False 
       .SaveData = True 
       .AdjustColumnWidth = True 
       .RefreshPeriod = 0 
       .PreserveColumnInfo = True 
       .Refresh 
       ' @@ QueryTable commands END 
      End With 
     ' Cmd for system and application to do non-macro related events 
     DoEvents 
     Application.ScreenUpdating = True 
' ********************* 
' Begin duplicate part number consolidation 
     Application.ScreenUpdating = True 
     iRowL = Cells(Rows.Count, 1).End(xlUp).Row 
     'Cycle through all the cells in that column: 
      For iRow = 3 To iRowL 
       If Cells(iRow, 2) = Cells((iRow + 1), 2) Then 
        iCountA = 0 
        Do While (Cells(iRow, 2) = Cells((iRow + 1), 2)) And (IsEmpty(Cells(iRow, 1)) = False) 
         iRowValue = (Cells(iRow, 4) + Cells((iRow + 1), 4)) 
         Cells(iRow, 4) = iRowValue 
         Rows(iRow + 1).EntireRow.Delete 
         iCountA = iCountA + 1 
         If iCountA > 20 Then 
          Exit Do 
         Else 
         End If 
        Loop 
       Else 
       End If 
      Next iRow 
     ' Cmd for system and application to do non-macro related events 
     DoEvents 
     Application.ScreenUpdating = True 
     ' Cmd for system and application to do non-macro related events 
     DoEvents 
' ********************* 
' Reset variables and Begin checking for sub-assemblies 
     iRow = 0 
     iRowValue = 0 
     iRowL = 0 
     'Set up the count as the number of filled rows in the first column of Sheet1. 
     iRowL = Cells(Rows.Count, 1).End(xlUp).Row 
     'Cycle through all the cells in that column: 
      For iRow = 3 To iRowL 
       sShtName = Cells(iRow, 2).Value 
       If (InStr(1, Cells(iRow, 2).Value, "772") And Not WksExists(sShtName)) Then 
         Worksheets.Add after:=Worksheets(Worksheets.Count) 
         ActiveSheet.Name = sShtName 
         'Sheets(ws.Name).Activate 
         'ThisWorkbook.Save 
        ElseIf (InStr(1, Cells(iRow, 2).Value, "993") And Not WksExists(sShtName)) Then 
         Worksheets.Add after:=Worksheets(Worksheets.Count) 
         ActiveSheet.Name = sShtName 
         'Sheets(ws.Name).Activate 
         'ThisWorkbook.Save 
        ElseIf (InStr(1, Cells(iRow, 2).Value, "995") And Not WksExists(sShtName)) Then 
         Worksheets.Add after:=Worksheets(Worksheets.Count) 
         ActiveSheet.Name = sShtName 
         'Sheets(ws.Name).Activate 
         'ThisWorkbook.Save 
        ElseIf (InStr(1, Cells(iRow, 2).Value, "996") And Not WksExists(sShtName)) Then 
         Worksheets.Add after:=Worksheets(Worksheets.Count) 
         ActiveSheet.Name = sShtName 
         'Sheets(ws.Name).Activate 
         'ThisWorkbook.Save 
        ElseIf (InStr(1, Cells(iRow, 2).Value, "997") And Not WksExists(sShtName)) Then 
         Worksheets.Add after:=Worksheets(Worksheets.Count) 
         ActiveSheet.Name = sShtName 
         'Sheets(ws.Name).Activate 
         'ThisWorkbook.Save 
        Else 
       End If 
      'change active workbook sheet 
      Sheets(ws.Name).Activate 
      sShtName = "" 
      Next iRow 
    Else 
    End If 
    ' Cmd for system and application to do non-macro related events 
    DoEvents 
    Application.ScreenUpdating = True 
    ' change active workbook sheet back to Main 
    Sheets("Main").Activate 
Next ws 

End Sub 

Answer 1

一般要尽量避免在您同时循环播放时修改任何收藏集。

您可能更容易将所有现有工作表添加到Collection，然后处理该工作表中的第一项，处理该工作表，然后将其从集合中删除。当您从集合中删除所有项目时结束循环。

如果您在处理过程中添加一张或多张新纸张，请将其添加到收藏夹中以确保他们也会得到处理。

下面是这种做法的一个简单的例子：

Sub TestSheetLoop() 
Dim colSheets As New Collection 
Dim sht As Worksheet, shtNew As Worksheet 

    'grab all existing sheets 
    For Each sht In ThisWorkbook.Worksheets 
     colSheets.Add sht 
    Next sht 

    Do While colSheets.Count > 0 

     Set sht = colSheets(1) 
     Debug.Print sht.Name 
     '********************* 
     '...process this sheet 
     '********************* 

     'adding a new sheet... 
     If sht.Name = "Sheet2" Then 
      Set shtNew = ThisWorkbook.Sheets.Add() 
      shtNew.Name = "New sheet" 
      'add to collection 
      colSheets.Add shtNew 
     End If 

     'remove the sheet we just processed 
     colSheets.Remove (1) 
    Loop 

End Sub