Split data from workbook into multiple and save

[albertod8]

Hi,

I have a file with data for multiple countries and would need to generate a separate workbook for each country only with the data for that country.

First, I would like to ask the user where he would like to save the files. After he choses the folder where to save all files, the code would need to filter in "Sheet 1", column C for one Country (lets say Spain), copy the data paste it in the new workbook, and save the new workbook as "Data Spain 2023". Once it is done for Spain, should do the same for France, Italy and Germany.

Could you please help?
Thanks

 

[kevin9999]

Please supply a sample of your workbook using the XL2BB - Excel Range to BBCode or alternatively, share your file via Dropbox, Google Drive or similar file sharing site.

 

[John_w]

Try this macro:

Public Sub Split_Sheet_By_Country()

    Dim destFolder As String
    Dim CountriesDict As Object 'Scripting.Dictionary
    Dim CountryCell As Range, CountryKey As Variant
    Dim filteredCells As Range
    Dim CountryWorkbook As Workbook
    Dim AutoFilterWasOn As Boolean
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the destination folder"
        .InitialFileName = ActiveWorkbook.Path
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        destFolder = .SelectedItems(1) & "\"
    End With
    
    Application.ScreenUpdating = False
    
    Set CountriesDict = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
    
    Application.ScreenUpdating = False
    
    With ActiveWorkbook.ActiveSheet
    
        AutoFilterWasOn = .AutoFilterMode
    
        'Create dictionary of unique Country values from column C
        
        For Each CountryCell In .Range("C2:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
            If Not CountriesDict.Exists(CountryCell.Value) Then CountriesDict.Add CountryCell.Value, 1
        Next
    
        'Autofilter column C by each Country and copy results to new workbooks
        
        For Each CountryKey In CountriesDict.Keys
    
            'Filter on column C to show only rows for this date

            .UsedRange.AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:="=" & CountryKey
            Set filteredCells = .UsedRange.SpecialCells(xlCellTypeVisible)
            
            'Copy filtered cells to new workbook
            
            Set CountryWorkbook = Workbooks.Add(xlWBATWorksheet)
            filteredCells.Copy CountryWorkbook.Worksheets(1).Range("A1")
            Application.DisplayAlerts = False 'suppress warning if file already exists
            CountryWorkbook.SaveAs destFolder & "Data " & CountryKey & " 2023.xlsx", xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            CountryWorkbook.Close False
            
        Next
    
        'Restore autofilter if it was on
        
        .AutoFilter.ShowAllData
        If Not AutoFilterWasOn Then .AutoFilterMode = False
        
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub

 

[albertod8]

Thanks John, it works.
I am trying to add the Country to a dropdown (B2) in "Sheet2" and then copy that sheet into the same file as well before saving.

If you could help adding this to the macro would really appreciate. I will mark your the question as answered anyway, thanks for your help!!

 

[John_w]

I am trying to add the Country to a dropdown (B2) in "Sheet2" and then copy that sheet into the same file as well before saving.

Assuming the dropdown is a data validation list:

Public Sub Split_Sheet1_By_Country2()

    Dim destFolder As String
    Dim CountriesDict As Object 'Scripting.Dictionary
    Dim CountryCell As Range, CountryKey As Variant
    Dim filteredCells As Range
    Dim CountryWorkbook As Workbook
    Dim AutoFilterWasOn As Boolean
    Dim DVcell As Range, DVlist As String
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the destination folder"
        .InitialFileName = ActiveWorkbook.Path
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        destFolder = .SelectedItems(1) & "\"
    End With
   
    Application.ScreenUpdating = False
   
    Set CountriesDict = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
   
    'Save current data validation list
   
    Set DVcell = ActiveWorkbook.Worksheets("Sheet2").Range("B2")
    DVlist = DVcell.Validation.Formula1
   
    Application.ScreenUpdating = False
   
    With ActiveWorkbook.Worksheets("Sheet1")
   
        AutoFilterWasOn = .AutoFilterMode
   
        'Create dictionary of unique Country values from column C
       
        For Each CountryCell In .Range("C2:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
            If Not CountriesDict.Exists(CountryCell.Value) Then CountriesDict.Add CountryCell.Value, 1
        Next
   
        'Autofilter column C by each Country and copy results to new workbooks
       
        For Each CountryKey In CountriesDict.Keys
   
            'Filter on column C to show only rows for this Country

            .UsedRange.AutoFilter Field:=3, Operator:=xlFilterValues, Criteria1:="=" & CountryKey
            Set filteredCells = .UsedRange.SpecialCells(xlCellTypeVisible)
           
            'Copy filtered cells to new workbook
           
            Set CountryWorkbook = Workbooks.Add(xlWBATWorksheet)
            filteredCells.Copy CountryWorkbook.Worksheets(1).Range("A1")
           
            'Add this Country to data validation list
           
            DVcell.Validation.Modify Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=DVlist & "," & CountryKey
           
            'Copy sheet containing data validation cell to the new workbook
           
            DVcell.Parent.Copy After:=CountryWorkbook.Worksheets(1)
           
            Application.DisplayAlerts = False 'suppress warning if file already exists
            CountryWorkbook.SaveAs destFolder & "Data " & CountryKey & " 2023.xlsx", xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            CountryWorkbook.Close False
           
        Next
   
        'Restore autofilter if it was on
       
        .AutoFilter.ShowAllData
        If Not AutoFilterWasOn Then .AutoFilterMode = False
       
        'Restore data validation list
       
        DVcell.Validation.Modify Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=DVlist
       
    End With
   
    Application.ScreenUpdating = True
   
    MsgBox "Done"

End Sub