Создание новой рабочей книги и рабочих листов для нескольких критериев с VBA

Question

У меня есть таблица, которая выглядит так в Excel, начиная с «А1»

Name    Age Address Contact Group   Measure
Jim     32  aaa     abc     Stark   Prev1
Joe     22  bbb     abc     Stark   Prev2
Bob     22  ccc     abc     Stark   HM
Greg    22  ddd     efg     Stark   TM
Ted     39  eee     efg     Rank    Prev1
Jack    20  fff     efg     Rank    Prev2
Sam     30  aaa     hij     Rank    HM
Lisa    37  bbb     hij     Rank    TM
Ashley  37  ccc     hij     Rank    Prev1
Linda   31  ddd     klm     Rank    Prev2
Liz     39  eee     klm     Crazy   HM
Tyler   33  fff     klm     Crazy   TM
Blake   27  aaa     nop     Crazy   Prev1
Dustin  38  bbb     nop     Crazy   Prev2

Я пытаюсь создать новую книгу для каждой группы, а затем создать вкладку (лист), каждый из которых отличается измерения.

Я хочу назвать каждую книгу именем группы.

Так что в этом случае у меня будет 3 листа (Stark, Rank и Crazy), и у них будет по 4 разных вкладки. Ранг закончится еще парой строк.

Итак, я прошёл один лист идеально, но при попытке l oop для нескольких листов я получаю сообщение об ошибке в этой строке.

Ошибка времени выполнения - Ошибка автоматизации

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

Answer 1

Ошибка связана с тем, что вы закрыли newBook внутри вашего l oop и не смогли переназначить значение перед повторной ссылкой на newBook. В строке ошибки вы пытаетесь добавить лист в несуществующую (неназначенную) книгу. Это становится еще более проблематичным c на следующей строке при попытке Activate закрытой книги.

---

Вам нужно создать книгу внутри l oop

т.е. переместите указанную ниже строку внутрь For Each Group l oop, но перед For Each Measure l oop. Новая книга должна быть создана прежде, чем на нее можно будет ссылаться ( обратите внимание, что ссылка закрывается, когда книга закрыта )

Set newBook = Workbooks.Add(xlWBATWorksheet)