筛选数据后创建新工作簿

Question

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

问题是每次脚本继续创建新工作簿并粘贴复制的数据时，我都会收到错误 运行-time Error 9: Subscript out of range 正好在下面加粗的行中：

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

筛选数据后创建新工作簿

Creating new workbooks after filtering data

vba

loops

filtering

filter