Save each data row in a separate, new CSV

Question

I've been struggling today with some VBA and have been looking on Stack for a solution to my problem, unfortunately I haven't had any luck whatsoever and so was wondering if somebody could help out. Would be extremely grateful for any assitance, I'm almost pulling my hair out right now. :)

• I have lots of data (400+ rows) from an experiment in a big .XLSX document.
• The document has 1 column with a name in it and 8 subsequent columns with data points in it. Here is an excerpt from the document:

Original Data

• I need to find a way of exporting each row of the original data with the table header (excluding the name column) into a new .CSV file which is named after the name provided in the first column:

Example Final CSV Export, Filename: D29.csv

• This would have to iterate over all of the 400+ rows and therefore the end result would be 400 .CSV files.

Answer 1

Please try this code.

Sub RowsToCSV()
    ' Variatus @STO 06 Apr 2020

    Dim Sinw As Integer                     ' remember setting
    Dim Path As String
    Dim Fn As String                        ' file name
    Dim Ws As Worksheet                     ' for input
    Dim CapsRng As Range
    Dim Rng As Range
    Dim Cl As Long                          ' last column
    Dim Rl As Long                          ' last row
    Dim R As Long

    ' you can specify another open workbook
    Set Ws = ThisWorkbook.Worksheets("Data")
    ' you can specify another output path but it must exist
    Path = Environ("UserProfile") & "\Desktop\CSV Test files\"

    With Application
        Sinw = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False              ' over-write existing without warning
    End With

    With Ws
        Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
        Cl = .Cells(1, .Columns.Count).End(xlToLeft).Column
        Set CapsRng = .Cells(1, 1).Resize(1, Cl)
        For R = 2 To Rl                     ' start in row 2
            Set Rng = Application.Union(CapsRng, .Cells(R, 1).Resize(1, Cl))
            ' modify the file name here:-
            Fn = Format(Date, "yymmdd ") & "Test " & _
                 Trim(.Cells(R, 1).Value) & ".csv"
            With Workbooks.Add
                Rng.Copy Destination:=.Sheets(1).Cells(1, 1)
                .SaveAs Path & Fn, xlCSV
                .Close SaveChanges:=False
            End With
        Next R
    End With

    With Application
        .SheetsInNewWorkbook = Sinw         ' return to original setting
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub