創建新工作表時從模塊內部更新工作簿的內部工作表列表

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