Split into multiple files

[cute0angel0]

"Hello everyone,

I have an Excel file that I would like to split into multiple files based on the months of the year. Specifically, I want to create separate files for each month (January, February, etc.) and have the data for that month within that file. The dates I need to use for this split are located in column J of my Excel sheet.

Could you please provide me with a VBA (Visual Basic for Applications) code that can automate this process?

Thank you in advance for your help!"

 

[cute0angel0]

https://www.mediafire.com/file/orqgsct9ps5cmjv/المقيمين+النشطين2_10_2025.xlsb/file THIS MY FILE

 

[HongRu]

Try.

Sub split_files()
    Dim myPath As String
    myPath = ThisWorkbook.Path  ' set the path to save files
    
    Dim myFileName As String
    Dim Ws As Worksheet
    Set Ws = ActiveSheet ' set the sheet to split
    
    Dim Rng As Range
    Set Rng = Ws.Range("J1").CurrentRegion ' set the data to split
    
    Dim N_Rows
    N_Rows = Rng.Rows.Count ' numbers of data
    
    Dim Keys ' Dates of data
    Keys = Range("J1").Resize(N_Rows).Value
    
    Dim Check_Unique As String ' to check the unique of dates
    
    Dim year_month As String 'year and month to filter
    Dim i
    Range("J1").AutoFilter ' reset Autofilter
    
    For i = 2 To N_Rows
        year_month = WorksheetFunction.Text(Keys(i, 1), "yyyymm")
        If InStr(1, Check_Unique, year_month) = 0 Then
            Check_Unique = Check_Unique & "," & year_month
            Range("J1").AutoFilter Field:=Range("J1").Column - Rng.Column + 1, Operator:= _
                xlFilterValues, Criteria2:=Array(1, Keys(i, 1))
            Range("J1").CurrentRegion.Copy
            
            Workbooks.Add
            Range("A1").Offset(0, Rng.Column - 1).PasteSpecial
            myFileName = myPath & "\" & "file_" & year_month & ".xlsx"
            ActiveWindow.Close True, myFileName
        End If
    Next i
    
    Range("J1").AutoFilter
End Sub

 

[cute0angel0]

Try.

Sub split_files()
    Dim myPath As String
    myPath = ThisWorkbook.Path  ' set the path to save files
   
    Dim myFileName As String
    Dim Ws As Worksheet
    Set Ws = ActiveSheet ' set the sheet to split
   
    Dim Rng As Range
    Set Rng = Ws.Range("J1").CurrentRegion ' set the data to split
   
    Dim N_Rows
    N_Rows = Rng.Rows.Count ' numbers of data
   
    Dim Keys ' Dates of data
    Keys = Range("J1").Resize(N_Rows).Value
   
    Dim Check_Unique As String ' to check the unique of dates
   
    Dim year_month As String 'year and month to filter
    Dim i
    Range("J1").AutoFilter ' reset Autofilter
   
    For i = 2 To N_Rows
        year_month = WorksheetFunction.Text(Keys(i, 1), "yyyymm")
        If InStr(1, Check_Unique, year_month) = 0 Then
            Check_Unique = Check_Unique & "," & year_month
            Range("J1").AutoFilter Field:=Range("J1").Column - Rng.Column + 1, Operator:= _
                xlFilterValues, Criteria2:=Array(1, Keys(i, 1))
            Range("J1").CurrentRegion.Copy
           
            Workbooks.Add
            Range("A1").Offset(0, Rng.Column - 1).PasteSpecial
            myFileName = myPath & "\" & "file_" & year_month & ".xlsx"
            ActiveWindow.Close True, myFileName
        End If
    Next i
   
    Range("J1").AutoFilter
End Sub

thanks alote