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

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