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

Gliffix101

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

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

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
50,563
Office Version
  1. 365
Platform
  1. Windows
You need to change
VBA Code:
Dim ws2 As Range
to
VBA Code:
Dim ws2 As WorkSheet
 

Gliffix101

Board Regular
Joined
Apr 1, 2014
Messages
77
Of course it was that easy. So now I corrected and ran again and running into an issue on this code line:

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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
50,563
Office Version
  1. 365
Platform
  1. Windows
If you want to save the files in the same folder as the original workbook use
VBA Code:
FPath = Workbk.Path
 

Watch MrExcel Video

Forum statistics

Threads
1,118,126
Messages
5,570,334
Members
412,319
Latest member
akshat1231
Top