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

DECOVIOTI

New Member
Joined
Dec 11, 2020
Messages
22
Office Version
  1. 2019
Platform
  1. Windows
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.

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

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,875
Hi DECOVIOTI,

Sounds like a job for SaveCopyAs:

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

DECOVIOTI

New Member
Joined
Dec 11, 2020
Messages
22
Office Version
  1. 2019
Platform
  1. Windows
Hi DECOVIOTI,

Sounds like a job for SaveCopyAs:

VBA Code:
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
 
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,152,038
Messages
5,767,784
Members
425,434
Latest member
ecrodrig

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