Excel File Split Macro

Silver Contributor

Sep 04, 2020

I have written the entire code from scratch. Please test it and let me know if that works fine on your end.

Sub Breakout()
    Dim wsTemplate      As Worksheet
    Dim wsControl       As Worksheet
    Dim wbReport        As Workbook
    Dim Rng             As Range
    Dim Cel             As Range
    Dim lr              As Long
    Dim tlr             As Long
    Dim strFileName     As String
    Dim strFilePath     As String
    Dim dt              As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wsTemplate = ThisWorkbook.Worksheets("Template")
    Set wsControl = ThisWorkbook.Worksheets("Control")
        
    If wsControl.Range("E1").Value = "" Then
        MsgBox "Please input the path for the destination file in E1 on Control Sheet first and then try again...", vbExclamation
        Exit Sub
    End If
    
    strFilePath = wsControl.Range("E1").Value
    
    If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & Application.PathSeparator
    
    If Dir(strFilePath, vbDirectory) = "" Then
        MsgBox "The folder " & strFilePath & " doesn't exist.", vbExclamation
        Exit Sub
    End If
    dt = Sheets("Control").Range("E2").Value
    
    wsTemplate.AutoFilterMode = False
    tlr = wsTemplate.Cells(Rows.Count, 1).End(xlUp).Row
    wsTemplate.Sort.SortFields.Clear
    wsTemplate.Range("A1").Sort key1:=wsTemplate.Range("A2"), order1:=xlAscending, Header:=xlYes
    
    lr = wsControl.Cells(Rows.Count, 1).End(xlUp).Row
    Set Rng = wsControl.Range("A2:A" & lr)
    
    For Each Cel In Rng
        If Cel.Value <> "" Then
            wsTemplate.Rows(1).AutoFilter field:=1, Criteria1:=Cel.Value
            If wsTemplate.Range("A1:A" & tlr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                strFileName = dt & Cel.Value & ".xls"
                strFileName = strFilePath & strFileName
                wsTemplate.Copy
                Set wbReport = ActiveWorkbook
                wbReport.SaveAs Filename:=strFileName, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                wbReport.Close True
            End If
        End If
    Next Cel
    If wsTemplate.FilterMode Then wsTemplate.ShowAllData
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
    MsgBox "Task completed!", vbInformation
End Sub

In the attached, click the button called "Create Reports" on Control Sheet to run the code.

TEMPLATE Breakout_Files_Macro v2.xlsm74 KB

JoeCavasin

Brass Contributor

Dec 10, 2020

Subodh_Tiwari_sktneer

Evening Subodh, sorry to be so slow in testing this but other priorities took over the last few months. I did test it out today and it definitely runs smoother than my prior version and only outputs the number of files based on which id's are present in column A on the template tab. However one odd thing happened that I could not work around. The files exported were full copies of the data from the Template tab, however they were filtered down to a single identifier in column A. So instead of actually breaking out the data, they were just multiple copies, filtered down. Attaching the updated master copy and one output file as an example for review.

Thanks again!

Joe

UHC Breakout_Files_Macro Update Copy.xlsm72 KB

Test TIN 1.xls29 KB

Subodh_Tiwari_sktneer

Silver Contributor

Dec 10, 2020

JoeCavasin

Okya, try it like this...

Option Explicit
Sub Breakout()
    Dim wsTemplate      As Worksheet
    Dim wsControl       As Worksheet
    Dim wbReport        As Workbook
    Dim wsReport        As Worksheet
    Dim Rng             As Range
    Dim Cel             As Range
    Dim lr              As Long
    Dim tlr             As Long
    Dim strFileName     As String
    Dim strFilePath     As String
    Dim dt              As String
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Set wsTemplate = ThisWorkbook.Worksheets("Template")
    Set wsControl = ThisWorkbook.Worksheets("Control")
        
    If wsControl.Range("E1").Value = "" Then
        MsgBox "Please input the path for the destination file in E1 on Control Sheet first and then try again...", vbExclamation
        Exit Sub
    End If
    
    strFilePath = wsControl.Range("E1").Value
    
    If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & Application.PathSeparator
    
    If Dir(strFilePath, vbDirectory) = "" Then
        MsgBox "The folder " & strFilePath & " doesn't exist.", vbExclamation
        Exit Sub
    End If
    
    dt = wsControl.Range("E2").Value
    If IsDate(dt) = False Then
        MsgBox "There is no date in cell E2 on Control Sheet.", vbExclamation, "Date Missing!"
        Exit Sub
    End If
    
    wsTemplate.AutoFilterMode = False
    tlr = wsTemplate.Cells(Rows.Count, 1).End(xlUp).Row
    wsTemplate.Sort.SortFields.Clear
    wsTemplate.Range("A1").Sort key1:=wsTemplate.Range("A2"), order1:=xlAscending, Header:=xlYes
    
    lr = wsControl.Cells(Rows.Count, 1).End(xlUp).Row
    Set Rng = wsControl.Range("A2:A" & lr)
    
    For Each Cel In Rng
        If Cel.Value <> "" Then
            wsTemplate.Rows(1).AutoFilter field:=1, Criteria1:=Cel.Value
            If wsTemplate.Range("A1:A" & tlr).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
                strFileName = dt & Cel.Value & ".xls"
                strFileName = strFilePath & strFileName
                Set wbReport = Workbooks.Add
                Set wsReport = wbReport.Worksheets(1)
                wsReport.Name = "Template"
                wsTemplate.Range("A1").CurrentRegion.Copy
                wsReport.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
                wsReport.Range("A1").PasteSpecial xlPasteColumnWidths
                wsReport.Range("A1").PasteSpecial xlPasteFormats
                
                Application.CutCopyMode = False
                wbReport.SaveAs Filename:=strFileName, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                wbReport.Close True
            End If
        End If
        Set wsReport = Nothing
        Set wbReport = Nothing
    Next Cel
    If wsTemplate.FilterMode Then wsTemplate.ShowAllData
    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
    MsgBox "Task completed!", vbInformation
End Sub

Forum Discussion

Resources