Excel VBA Create Sheets with unique values and save as workbooks

[Gliffix101]

Hi All -

I have a macro that will filter Column C on unique values, move them to new sheets, and then create new workbooks for each sheet. I am running into a Runtime Error 9, Subscript out of range on the line

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

. I am sure there is a more efficient way to write this, but this is where I am at for now. Ideally it would filter Column C for each unique value, copy/paste all visible data to a new workbook, save the workbook as the unique value, and then email each workbook out separately. I haven't gotten that far (mostly because I'm terrible with loops). Any help is appreciated.

One important note - this macro is saved in my Personal Macro book because I am running this against an emailed file.

Option Explicit

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim ws 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

'renaming the dated output sheet as Data
ActiveSheet.Name = "Data"
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, "C").End(xlUp).Row

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

Workbk.Sheets(sht).Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Workbk.Sheets(sht).Range([AA2], Cells(Rows.Count, "AA").End(xlUp))

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

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

Dim FPath As String
FPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Workbk.Sheets(sht).AutoFilterMode = False

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

End Sub

 

[mrshl9898]

Try changing ThisWorkbook to ActiveWorkbook since the code is in your personal.

Set Workbk = ActiveWorkbook