Creating a new workbook and worksheets for multiple criteria with VBA

Question

I have a table that looks like this in excel starting in "A1"

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

I am trying to make a new book for each group and then create a tab(sheet) that has each different measure.

I want to name each book with the group name.

So in this case I would have 3 sheets (Stark,Rank and Crazy) and they would each have 4 different tabs. Rank would end up with a couple more lines.

So I get through one sheet perfect, but when I try to loop for multiple sheets I have been getting a error on this line.

Run-time error - Automation Error

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

What do I need to do to fix this?

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

The error is due to the fact that you have closed the newBook inside your loop and failed to re-assign a value before referencing newBook again. On your error line you are trying to add a sheet to a non-existing (unassigned) book. It becomes even more problematic on the next line when you try to Activate a closed book.

---

You need to create the book inside the loop

ie move the below line to be inside of For Each Group loop but before the For Each Measure loop. The new book needs to be created before it can ever be referenced ( note the reference dies when the book is closed )

Set newBook = Workbooks.Add(xlWBATWorksheet)