Excel VBA Create Sheets with unique values and save as workbooks

Gliffix101

Board Regular
Joined
Apr 1, 2014
Messages
77
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
VBA Code:
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.

VBA Code:
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
 

Some videos you may like

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,488
Try changing ThisWorkbook to ActiveWorkbook since the code is in your personal.

VBA Code:
Set Workbk = ActiveWorkbook
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,114,193
Messages
5,546,479
Members
410,742
Latest member
WalterSil
Top