Excel 使用VBA为多个条件创建新工作簿和工作表

在excel中，我有一个表格，从“A1”开始

我正在尝试为每个组制作一本新书，然后创建一个具有每个不同度量的选项卡（工作表）

我想用组名给每本书命名

因此，在这种情况下，我将有3张（斯塔克，排名和疯狂），他们将有4个不同的标签。Rank最后会多排几行

所以我完成了一张完美的工作表，但当我尝试循环多张工作表时，我在这一行遇到了一个错误

运行时错误-自动化错误

我需要做什么来解决这个问题

Option Explicit

Sub MakeNewSheets()
Application.ScreenUpdating = False
Dim Measure As Range
Dim Group 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 = "Data"

'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, "F").End(xlUp).Row

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

Workbk.Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
Workbk.Sheets(sht).Range("E1:E" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AB1"), Unique:=True

For Each Group In Workbk.Sheets(sht).Range([AB2], Cells(Rows.Count, "AB").End(xlUp))

    For Each Measure In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
    With rng
    .AutoFilter
    .AutoFilter Field:=6, Criteria1:=Measure.Value
    .AutoFilter Field:=5, Criteria1:=Group.Value
    .SpecialCells(xlCellTypeVisible).Copy

    newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Measure.Value
    newBook.Activate
    ActiveSheet.Paste
    End With
    Next Measure

    ' Delete sheet1 from newworkbook
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Delete
    Application.DisplayAlerts = True

    ' Save newworkbook as location


        newBook.Activate
        newBook.SaveAs "C:\Users\xxxxxxxxx\Desktop\" & Group.Value
        Workbooks(Group.Value & ".xlsx").Close SaveChanges:=False


Next Group


' Turn off filter

Workbk.Sheets(sht).AutoFilterMode = False

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

End Sub

---

该错误是由于您在循环中关闭了

newBook

，并且在再次引用

newBook

之前未能重新分配值。在错误行中，您试图将图纸添加到不存在（未指定）的书本中。当你试图

激活一本已关闭的书时，下一行的问题就更大了


您需要在循环中创建书本

i、 e.将下一行移动到每个组
循环的
内，但在每个测量
循环的
之前。在引用新书之前，需要先创建新书（请注意，当新书关闭时，引用将消失）

我认为你的问题措辞错误。每一组你都想要一本新书？对于每一项测量，你都需要一张新的表格，试图让它更清晰。非常感谢。
newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Measure.Value

Option Explicit

Sub MakeNewSheets()
Application.ScreenUpdating = False
Dim Measure As Range
Dim Group 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 = "Data"

'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, "F").End(xlUp).Row

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

Workbk.Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
Workbk.Sheets(sht).Range("E1:E" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AB1"), Unique:=True

For Each Group In Workbk.Sheets(sht).Range([AB2], Cells(Rows.Count, "AB").End(xlUp))

    For Each Measure In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
    With rng
    .AutoFilter
    .AutoFilter Field:=6, Criteria1:=Measure.Value
    .AutoFilter Field:=5, Criteria1:=Group.Value
    .SpecialCells(xlCellTypeVisible).Copy

    newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Measure.Value
    newBook.Activate
    ActiveSheet.Paste
    End With
    Next Measure

    ' Delete sheet1 from newworkbook
    Application.DisplayAlerts = False
    Worksheets("Sheet1").Delete
    Application.DisplayAlerts = True

    ' Save newworkbook as location


        newBook.Activate
        newBook.SaveAs "C:\Users\xxxxxxxxx\Desktop\" & Group.Value
        Workbooks(Group.Value & ".xlsx").Close SaveChanges:=False


Next Group


' Turn off filter

Workbk.Sheets(sht).AutoFilterMode = False

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

End Sub

Set newBook = Workbooks.Add(xlWBATWorksheet)