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
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce

mrshl9898

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

VBA Code:
Set Workbk = ActiveWorkbook
 
Solution
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,164,601
Messages
5,838,281
Members
430,536
Latest member
Manoj Gaidhankar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top