将数据从具有多个工作表的工作簿复制到多个新工作簿中，每个工作表上仅一行

Question

我有一个工作簿，其中包含多个工作表，每个工作表中都有多行。

我需要新的工作簿，这些工作簿应具有相同数量的工作表，并且每个工作表中都有一行。

例如：如果工作簿包含8个工作表，每个工作表中有200行，那么结果将是200个工作簿，其中包含8个工作表，其中1行。

源工作簿

结果工作簿（200个工作簿）

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

Answer 1

您找到解决问题的方法了吗？ 如果没有，我建议如下：

从第2行到最后一行的每一行都循环播放。在主循环内，创建工作簿并执行辅助循环以根据需要添加任意数量的工作表，然后关闭该循环。进行另一个辅助循环，以将标题行和当前（迭代）行复制到每个新创建的工作表中，然后关闭该循环。保存工作簿。