Сохраните каждую строку данных в отдельном, новом CSV

Question

Сегодня я боролся с каким-то VBA и искал в Stack решение моей проблемы, к сожалению, мне вообще не повезло, и поэтому мне было интересно, может ли кто-нибудь помочь. Был бы чрезвычайно признателен за любую помощь, я почти выдергиваю свои волосы прямо сейчас. :)

• У меня много данных (более 400 строк) из эксперимента в большом документе .XLSX.
• В документе есть 1 столбец с именем и 8 последующих столбцы с точками данных в нем. Вот выдержка из документа:

Исходные данные

• Мне нужно найти способ экспорта каждой строки исходных данных с помощью Заголовок таблицы (исключая столбец имени) в новый файл .CSV, который назван в честь имени, указанного в первом столбце:

Пример конечного экспорта CSV, имя файла: D29.csv

• Это должно было бы выполнить итерацию по всем 400+ строкам, и, следовательно, конечный результат будет 400 .CSV-файлами.

Answer 1

Пожалуйста, попробуйте этот код.

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