Split data to sheets and save as a csv

Hi all,

I'd like a macro which will:

1. create new sheets based on the text in Column A of the active sheet (source sheet) of where the macro is run
2. save just the new sheets which have been created as csv files in a new folder, with the folder name as date of when the macro is run.

I've attached an example workbook which hopefully highlights what I'm trying to achieve in step 1.

Here's some other specifics of what the macro should do, please:

- Shouldn't require a specific source sheet name, instead should work on whichever sheet is active i.e. whichever sheet I'm on when I run the macro
- Should not copy hidden columns from source sheet
- If there are duplicate values in Column A in the source sheet, then should be added to 1 single sheet (please see the attached workbook as an example)
- Create a folder with today's date in format 'dd.mm.yyyy' e.g. 21.05.2023. The location of the folder should be 'C:\Users\kevin\Work'. This is where the new csv's should be saved.
- It should also copy the visible headers from Row 1 on whichever source sheet the macro is being run.

Please note:
The data on source sheet will go to Column Z at the most (including the hidden columns), but will vary on each source sheet i.e. some sheets the data may go to Column Q, another one may go to Column S and another possibly all the way to Column Z. There data will go down to a maximum of 250 rows on any given source sheet.

The data in the attached workbook is example data and the actual structure of the text in each cell will be completely different (not that this should hopefully make a difference to create this macro).

Many thanks,
Kevin
P.s. I'm a novice at using macros - just know how to insert and run one!

Split Data To Sheets Example.xlsx

try

Sub test()
    Dim a, x, i As Long, ii As Long, myDir As String
    Dim ff As Long, wf As WorksheetFunction
    myDir = "C:\Users\kevin\Work\"
    If Dir(myDir, 16) = "" Then MsgBox "Wrong folder path", vbCritical, myDir: Exit Sub
    myDir = myDir & Format$(Date, "dd.mm.yyyy") & "\"
    If Dir(myDir, 16) = "" Then MkDir myDir
    Set wf = Application.WorksheetFunction
    With Sheets("source sheet 1").[a1].CurrentRegion
        ReDim x(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            If Not .Columns(i).Hidden Then ii = ii + 1: x(ii) = i
        Next
        ReDim Preserve x(1 To ii)
        a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
        x = wf.Unique(.Columns(1))
    End With
    ReDim Preserve x(1 To UBound(x, 1), 1 To 2)
    For i = 2 To UBound(x)
        x(i, 2) = wf.TextJoin(",", False, Application.Index(a, 1, 0))
        For ii = 2 To UBound(a, 1)
            If x(i, 1) = a(ii, 1) Then
                x(i, 2) = x(i, 2) & vbNewLine & wf.TextJoin(",", False, Application.Index(a, ii, 0))
            End If
        Next
    Next
    For i = 2 To UBound(x, 1)
        ff = FreeFile
        Open myDir & x(i, 1) & ".csv" For Output As ff
            Print #ff, x(i, 2);
        Close ff
    Next
End Sub

Originally Posted by jindon

try

Sub test()
    Dim a, x, i As Long, ii As Long, myDir As String
    Dim ff As Long, wf As WorksheetFunction
    myDir = "C:\Users\kevin\Work\"
    If Dir(myDir, 16) = "" Then MsgBox "Wrong folder path", vbCritical, myDir: Exit Sub
    myDir = myDir & Format$(Date, "dd.mm.yyyy") & "\"
    If Dir(myDir, 16) = "" Then MkDir myDir
    Set wf = Application.WorksheetFunction
    With Sheets("source sheet 1").[a1].CurrentRegion
        ReDim x(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            If Not .Columns(i).Hidden Then ii = ii + 1: x(ii) = i
        Next
        ReDim Preserve x(1 To ii)
        a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
        x = wf.Unique(.Columns(1))
    End With
    ReDim Preserve x(1 To UBound(x, 1), 1 To 2)
    For i = 2 To UBound(x)
        x(i, 2) = wf.TextJoin(",", False, Application.Index(a, 1, 0))
        For ii = 2 To UBound(a, 1)
            If x(i, 1) = a(ii, 1) Then
                x(i, 2) = x(i, 2) & vbNewLine & wf.TextJoin(",", False, Application.Index(a, ii, 0))
            End If
        Next
    Next
    For i = 2 To UBound(x, 1)
        ff = FreeFile
        Open myDir & x(i, 1) & ".csv" For Output As ff
            Print #ff, x(i, 2);
        Close ff
    Next
End Sub

This worked a treat, thank you!!

Originally Posted by jindon

try

Sub test()
    Dim a, x, i As Long, ii As Long, myDir As String
    Dim ff As Long, wf As WorksheetFunction
    myDir = "C:\Users\kevin\Work\"
    If Dir(myDir, 16) = "" Then MsgBox "Wrong folder path", vbCritical, myDir: Exit Sub
    myDir = myDir & Format$(Date, "dd.mm.yyyy") & "\"
    If Dir(myDir, 16) = "" Then MkDir myDir
    Set wf = Application.WorksheetFunction
    With Sheets("source sheet 1").[a1].CurrentRegion
        ReDim x(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            If Not .Columns(i).Hidden Then ii = ii + 1: x(ii) = i
        Next
        ReDim Preserve x(1 To ii)
        a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
        x = wf.Unique(.Columns(1))
    End With
    ReDim Preserve x(1 To UBound(x, 1), 1 To 2)
    For i = 2 To UBound(x)
        x(i, 2) = wf.TextJoin(",", False, Application.Index(a, 1, 0))
        For ii = 2 To UBound(a, 1)
            If x(i, 1) = a(ii, 1) Then
                x(i, 2) = x(i, 2) & vbNewLine & wf.TextJoin(",", False, Application.Index(a, ii, 0))
            End If
        Next
    Next
    For i = 2 To UBound(x, 1)
        ff = FreeFile
        Open myDir & x(i, 1) & ".csv" For Output As ff
            Print #ff, x(i, 2);
        Close ff
    Next
End Sub

I've just come across an unexpected issue with the code:

If there are any commas in the source sheet, when exporting it as a csv it removes the comma and pushes the text after each comma into the next column.

Could you please adjust the code so that it keeps the commas and prevents the text from splitting to the next column?

Many thanks!

1)
Please don't quote whole posts -- it's just clutter. If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

2) try change

        ReDim Preserve x(1 To ii)
        a = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), x)
        x = wf.Unique(.Columns(1))

to

        Dim s As String
        ReDim Preserve x(1 To ii): s = .Address
        a = Evaluate("if(isnumber(find("",""," & s & ")),char(34)&" & s & "&char(34),if(" & s & "<>""""," & s & ",""""))")
        a = Application.Index(a, Evaluate("row(1:" & .Rows.Count & ")"), x)
        x = wf.Unique(.Columns(1))