Folks,
The below code does advanced filter automatically and save the filtered data as new workbooks individually based on the criteria with file extension ".xlsx" in the "Master" workbook path. What I am looking for I have to save all new workbooks in another path (Master file path & \ backup folder) and the file extension should be ".xlsm". Can you please help me to fix this issue?
Sub DistributeRowsToNewWBS()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Set wsData = Worksheets("Master") ' name of worksheet with the data
Set wsCrit = Worksheets.Add
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
wsData.Range("A1:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add
' change E to reflect columns to copy
wsData.Range("A1:E" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
wsNew.Name = rngCrit
wsNew.Copy
Set wbNew = ActiveWorkbook
' saves new workbook in path of existing workbook
wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit
wbNew.Close SaveChanges:=True
Application.DisplayAlerts = False
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend
wsCrit.Delete
Application.DisplayAlerts = True
End Sub
Thanks in advance.
Joshi
Bookmarks