筛选数据后创建新工作簿

Question

我正在尝试修改此页面中的脚本：https://www.listendata.com/2015/04/excel-vba-filtering-and-copy-pasting-to.html在合成中，我可以过滤列中的每个唯一值，复制数据，创建一个新工作簿，然后将所述数据粘贴到循环中。

问题是，每次脚本继续创建新工作簿并粘贴复制的数据时，我都会收到错误运行时错误9：下标超出范围，精确地显示在下面粗体的行中：

Sub test()

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

' -------------------

Dim x As Range
Dim rng As Range
Dim rng1 As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook
'Specify sheet name in which the data is stored
sht = "Report"
'Workbook where VBA code resides
Set Workbk = ThisWorkbook
'New Workbook
Set newBook = Workbooks.Add(xlWBATWorksheet)
Workbk.Activate
'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "BR").End(xlUp).Row
With Workbk.Sheets(sht)
Set rng = .Range("A1:BR" & last)
End With
Workbk.Sheets(sht).Range("G1:G" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BT1"), Unique:=True
For Each x In Workbk.Sheets(sht).Range([BT2], Cells(Rows.Count, "BT").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=7, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
*newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value*
newBook.Activate
ActiveSheet.Paste
End With
Next x
' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' -------------------

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Check."

End Sub

值得一提的是，新工作簿已经创建。然而，它被困在这里，我看不出原因。

Answer 1

您被一个隐含的ActiveWorkbook咬了一口。

newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value

用有问题的工作簿限定Sheets：

newBook.Sheets.Add(After:=newBook.Sheets(newBook.Sheets.Count)).Name = x.Value