Filter data, copy to new workbook, and save to user desktop

[Gliffix101]

Ok - So I posted this code in another post and my question was answered. That fixed the initial issue but I am now running into a new error. I also keep coming across different posts that lead me to think there's a way to do this cleaner. My code is erroring out on this one line:

For Each ws2 In ActiveWorkbook.Sheets

Long story short, I receive a dated output file that I need to filter, copy, paste and save as a new workbook based on the filtered value in Column C. This macro is supposed to loop through each filter and save out, but this just keeps failing. I will appreciate and be extremely grateful for any and all help that can be offered.

One final IMPORTANT note - this code is saved to my Personal Macro Book due to the dated file received constantly having a new workbook name. The key is that the code needs to run from the user's personal macro book, and save all files onto the user's desktop for distribution.

Option Explicit

Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim ws As Range
Dim ws2 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
ActiveSheet.Name = "Data"
sht = "Data"

'Workbook where VBA code resides
Set Workbk = ActiveWorkbook

'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 ws2 In ActiveWorkbook.Sheets
    ws2.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws2.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

' Turn off filter
Workbk.Sheets(sht).AutoFilterMode = False

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

End Sub

 

[Fluff]

You need to change

Dim ws2 As Range

to

Dim ws2 As WorkSheet

 

[Gliffix101]

Of course it was that easy. So now I corrected and ran again and running into an issue on this code line:

Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws2.Name & ".xlsx"

I know it has to do with the fact that new workbook hasn't been saved to a location but any time I try to update, I fail. Thanks for taking a look.

 

[Fluff]

If you want to save the files in the same folder as the original workbook use

FPath = Workbk.Path