如何修改VBA代码，为批量生成的工作簿添加指定源工作表？

你的尝试语句出错的原因有两个：一是没有明确指定Sheets("Time")属于源工作簿（当前运行代码的工作簿），二是引用新工作簿的方式错误（Workbooks.newBook是错误写法，应该直接用定义好的newBook对象），而且Sheets.Count如果不指定工作簿，会默认指向当前激活的工作簿，容易引发错误。

以下是修改后的完整代码，实现筛选唯一值生成对应工作簿，并把源工作簿的「Bonus」和「Time」工作表完整复制到新工作簿中：

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
Dim newBook As Excel.Workbook
Dim Workbk As Excel.Workbook

sht = "kalkulátor"

Set Workbk = ThisWorkbook

last = Workbk.Sheets(sht).Cells(Rows.Count, "b").End(xlUp).Row

With Workbk.Sheets(sht)
    Set rng = .Range("A1:y" & last)
End With

' 提取B列唯一值到AA列
Workbk.Sheets(sht).Range("B1:B" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbk.Sheets(sht).Range("AA1"), Unique:=True

For Each x In Workbk.Sheets(sht).Range([AA2], Workbk.Sheets(sht).Cells(Rows.Count, "AA").End(xlUp))

    With rng
        .AutoFilter
        .AutoFilter Field:=2, Criteria1:=x.Value
        .SpecialCells(xlCellTypeVisible).Copy
    End With

    ' 创建新工作簿（仅含1个工作表）
    Set newBook = Workbooks.Add(xlWBATWorksheet)
    
    ' 粘贴筛选后的数据到新工作表并命名
    newBook.Sheets(1).Name = x.Value
    newBook.Sheets(x.Value).Paste
    
    ' 复制源工作簿的Time工作表到新工作簿末尾
    Workbk.Sheets("Time").Copy After:=newBook.Sheets(newBook.Sheets.Count)
    ' 复制源工作簿的Bonus工作表到新工作簿末尾
    Workbk.Sheets("Bonus").Copy After:=newBook.Sheets(newBook.Sheets.Count)

    ' 保存并关闭新工作簿
    newBook.SaveAs x.Value & ".xlsx"
    newBook.Close SaveChanges:=False

Next x

' 关闭筛选
Workbk.Sheets(sht).AutoFilterMode = False

With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With

End Sub

关键修改点说明： #

• 明确指定所有工作表的所属工作簿：比如Workbk.Sheets("Time")确保是从源工作簿复制，newBook.Sheets(newBook.Sheets.Count)明确指向新工作簿的最后一个工作表位置。
• 调整了新工作簿工作表命名的逻辑：原代码会新增一个工作表，现在直接修改初始的那个工作表名称，避免多余工作表。
• 把复制「Bonus」和「Time」工作表的代码放在新工作簿创建后、保存前，确保这两个表被加入新工作簿。

内容的提问来源于stack exchange，提问作者Márta Ricsóvári