附加代码全部位于excel VBAProject的模块中。代码将扫描所有现有工作表并检索数据，对其进行排序，甚至在找到子装配时创建新工作表。
问题是： （1）在重新运行之前，它不会对新创建的工作表执行任何任务。我认为问题与每次创建新工作表时强制工作簿更新它的工作表列表有关。 （2）例程似乎在运行结束时添加了一个与创建新工作表定义的标准不匹配的工作表。 （即子装配编号以772,993,995,996或997开头）
请注意，部分中已禁用代码，以便我可以跟踪我尝试过的一些内容，例如 - ＆＃39; 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
答案 0 :(得分：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