Create new workbooks (copies) of the entire current workbook based on multiple criteria (country) based on a specific column

[DECOVIOTI]

The current code below is copying only the data from a sheet called "MASTER" to NEW entire workbooks by looking at a specific column/range called country. e.g. USA, CANADA, MEXICO, IRELAND.

So, 4 countries means 4 new workbooks.(only data)

What I would like to change is: instead of only copy the data from "MASTER" sheet, I would like to create a duplicate copy of the entire workbook because in the file which contains the "Master"sheet there are charts/pivot tables.

My main goal is to avoid the user need to create four copies of the same file manually.

Sub filternewsheets()

Application.ScreenUpdating = FALSE

Dim x                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
sht = "Master"

'Workbook where VBA code resides
Set Workbk = ThisWorkbook

'change filter column in the following code
last = Workbk.Sheets(sht).Cells(Rows.Count, "Y").End(xlUp).Row

With Workbk.Sheets(sht)
    Set rng = .Range("B1:AP" & last)
End With

Workbk.Sheets(sht).Range("Y1:Y" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AZ1"), Unique:=True

' Loop through unique values in column
For Each x In Workbk.Sheets(sht).Range([AZ2], Cells(Rows.Count, "AZ").End(xlUp))
    
    With rng
        .AutoFilter
        .AutoFilter Field:=24, Criteria1:=x.Value
        .SpecialCells(xlCellTypeVisible).Copy
        
        'Add New Workbook in loop
        Set newBook = Workbooks.Add(xlWBATWorksheet)
        newBook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
        newBook.Activate
        ActiveSheet.Paste
    End With
    
    'Save the new file in the same folder
    newBook.SaveAs FileName:=ThisWorkbook.Path & "\" & x.Value & "_Report" & "_" & Format(Now, "ddmmyy_hhmmss")
    
    'Close workbook
    newBook.Close SaveChanges:=True
    
Next x

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

With Application
    .CutCopyMode = FALSE
    .ScreenUpdating = FALSE
End With

End Sub

 

[Trebor76]

Hi DECOVIOTI,

Sounds like a job for SaveCopyAs:

Option Explicit
Sub Macro1()

    Application.ScreenUpdating = False
    
    Dim x           As Range
    Dim last        As Long
    Dim sht         As String
    Dim strFileExtn As String
    Dim Workbk      As Workbook
    
    'Specify sheet name in which the data is stored
    sht = "Master"
    
    'Workbook where VBA code resides
    Set Workbk = ThisWorkbook
    
    'Grab file extension
    strFileExtn = Right(Workbk.Name, Len(Workbk.Name) - InStrRev(Workbk.Name, "."))
    
    'change filter column in the following code
    last = Workbk.Sheets(sht).Cells(Rows.Count, "Y").End(xlUp).Row
    
    Workbk.Sheets(sht).Range("Y1:Y" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbk.Sheets(sht).Range("AZ1"), Unique:=True
    
    'Loop through unique values in column
    last = Workbk.Sheets(sht).Cells(Rows.Count, "AZ").End(xlUp).Row
    For Each x In Workbk.Sheets(sht).Range("AZ2:AZ" & last)
        'Save the new file in the same folder
        Workbk.SaveCopyAs Filename:=Workbk.Path & "\" & x.Value & "_Report" & "_" & Format(Now, "ddmmyy_hhmmss") & "." & strFileExtn
    Next x
   
   Application.ScreenUpdating = True
   
End Sub

Regards,

Robert

 

[DECOVIOTI]

Hi DECOVIOTI,

Sounds like a job for SaveCopyAs:

Option Explicit
Sub Macro1()

    Application.ScreenUpdating = False
   
    Dim x           As Range
    Dim last        As Long
    Dim sht         As String
    Dim strFileExtn As String
    Dim Workbk      As Workbook
   
    'Specify sheet name in which the data is stored
    sht = "Master"
   
    'Workbook where VBA code resides
    Set Workbk = ThisWorkbook
   
    'Grab file extension
    strFileExtn = Right(Workbk.Name, Len(Workbk.Name) - InStrRev(Workbk.Name, "."))
   
    'change filter column in the following code
    last = Workbk.Sheets(sht).Cells(Rows.Count, "Y").End(xlUp).Row
   
    Workbk.Sheets(sht).Range("Y1:Y" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Workbk.Sheets(sht).Range("AZ1"), Unique:=True
   
    'Loop through unique values in column
    last = Workbk.Sheets(sht).Cells(Rows.Count, "AZ").End(xlUp).Row
    For Each x In Workbk.Sheets(sht).Range("AZ2:AZ" & last)
        'Save the new file in the same folder
        Workbk.SaveCopyAs Filename:=Workbk.Path & "\" & x.Value & "_Report" & "_" & Format(Now, "ddmmyy_hhmmss") & "." & strFileExtn
    Next x
  
   Application.ScreenUpdating = True
  
End Sub

Regards,

Robert

Hello @Trebor76

Thanks for your assistance. I will definitely work on it based on your solution. I will let you know the results.
Thanks for the time to help me. Have a good day

 

[DECOVIOTI]

Thanks for the assistance. It worked

 

[Trebor76]

Thanks for the assistance. It worked

You're welcome