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

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