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

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