Automatic spreadsheet generation in Excel VBA

Question

My friend and I currently have a master spreadsheet that I need to be broken out into smaller spreadsheets regularly. This used to be a manual process, but I'd like to automate it. I created a three step solution in VBA which would help me accomplish this that did the following:

1. Apply relevant filters to spreadsheet
2. Export data currently visible after filter into new spreadsheet
3. Save spreadsheet and go back to 1 (different criteria)

Unfortunately I am having a hard time implementing it. Whenever I try to generate the spreadsheet, my document hangs, starts performs several calculations and then gives this me this error message:

Upon debugging the code, I get an error message at this line:

One Excel workbook is left open and only one row is visible (the second row pulled from the Master which contains header information) and nothing else.

What exactly is going on here?

This is my code so far:

The heart of it all

' This bit of code get's all the primary contacts in column F, it does 
' this by identifying all the unique values in column F (from F3 onwards)   
Sub GetPrimaryContacts()   
    Dim Col As New Collection
    Dim itm
    Dim i As Long
    Dim CellVell As Variant 

    'Get last row value
    LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row  

    'Loop between all column F to get unique values
    For i = 3 To LastRow
        CellVal = Sheets("Master").Range("F" & i).Value
        On Error Resume Next
        Col.Add CellVal, Chr(34) & CellVal & Chr(34)
        On Error GoTo 0
    Next i    

    ' Once we have the unique values, apply the TOKEN NOT ACTIVATED FILTER
    Call TokenNotActivated
    For Each itm In Col
        ActiveSheet.Range("A2:Z2").Select
        Selection.AutoFilter Field:=6, Criteria1:=itm          
        ' This is where the magic happens... creating the individual workbooks
        Call TokenNotActivatedProcess
    Next
    ActiveSheet.AutoFilter.ShowAllData   
End Sub

The "token not activated" filter

Sub TokenNotActivated()    
'Col M = Yes
'Col U = provisioned
ThisWorkbook.Sheets(2).Activate
ActiveSheet.Range("A2:Z2").Select
Selection.AutoFilter Field:=13, Criteria1:="Yes"
Selection.AutoFilter Field:=21, Criteria1:="provisioned", Operator:=xlFilterValues   
End Sub

Running the process to get the workbooks saved

Function TokenNotActivatedProcess()
    Dim r As Range, n As Long, itm, FirstRow As Long
    n = Cells(Rows.Count, 1).End(xlUp).Row
    Set r = Range("A1:A" & n).Cells.SpecialCells(xlCellTypeVisible)
    FirstRow = ActiveSheet.Range("F2").End(xlDown).Row
    itm = ActiveSheet.Range("F" & FirstRow).Value
    If r.Count - 2 > 0 Then Debug.Print itm & " - " & r.Count - 2
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:="C:\Working\Testing\TokenNotActivated - " & itm + ".xls", FileFormat:=52, CreateBackup:=False
End Function

Answer 1

This error is caused by trying to filter an empty range. After analysing your code, my guess is that you are missing a worksheet activation here, since repeating the line ActiveSheet.Range("A2:Z2").Select after calling the function TokenNotActivated does not make sense and maybe your code is trying to filter some empty range/worksheet.