Copy data from workbook with multiple worksheets into multiple new workbooks with only one row on each worksheet

Question

I have a workbook with multiple worksheets with multiple rows in each worksheet.

I need new workbooks with the same number of worksheets and one row in each worksheet.

ex: if the workbook contain 8 worksheets with 200 rows in each worksheet, the result will be 200 workbooks containing 8 worksheets with 1 row.

Source Workbook

result Workbook (200 workbooks)

Sub Method()

    Dim i As Long
    Dim TotalRows As Long

    Application.ScreenUpdating = False

    myPath = ActiveWorkbook.Path
    If Right(myPath, 1) <> "\" Then myPath = myPath & "\"

    'Count the total rows in the source sheet
    TotalRows = Range(Range("A2"), Range("A2").End(xlDown)).Rows.Count         
    For i = 1 To TotalRows

        With Sheets("Report1")
            .Rows(2 & ":" & .Rows.Count).ClearContents 'Where X is a variable that = the row number
        End With

        'Copy range to clipboard
        Workbooks("Source.xlsx").Worksheets("Source1").Range("A" & i).Copy

        'PasteSpecial to paste values, formulas, formats, etc.
        Workbooks("Reports.xlsb").Worksheets("Report1").Range("A2" & i).PasteSpecial Paste:=xlPasteValues
        Filename = "ADMS_" & "BTS" & ADMS & ".xlsx"     'Name of saved file

        Application.DisplayAlerts = False

        ActiveWorkbook.SaveAs Filename:=myPath & Filename, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        'ActiveWorkbook.Close True
        Application.DisplayAlerts = True

    Next i

    Application.ScreenUpdating = True

End Sub

Welcome to Stack Overflow! Please edit your question to show what you've tried, where you're stuck, example input/output, errors, etc. As currently written, it's a broad set of requirements (and, as such, off-topic). — David Makogon
Be careful with xlDown,... it can give unreliable result. Instead of TotalRows = Range(Range("A2"), Range("A2").End(xlDown)).Rows.Count I suggest TotalRows = Range("A" & Rows.Count).End(xlUp).Row - 1 . Check out Error in finding last used cell in VBA for more details. — PonderingPanda

PonderingPanda PonderingPanda · Accepted Answer · 2019-04-29T11:06:35

Have you found a solution to your problem? If not, i suggest the following :

Loop on every row from row 2 to final row. Inside the main loop, create a workbook and do a secondary loop to add as many sheets as needed, then close this loop. Do another secondary loop to copy the heading row and the current (iterated) row into each newly created worksheet, then close this loop. Save workbook.

Copy data from workbook with multiple worksheets into multiple new workbooks with only one row on each worksheet

1 Answers