将数据从具有多个工作表的工作簿复制到多个新工作簿中，每个工作表上仅一行 [英] Copy data from workbook with multiple worksheets into multiple new workbooks with only one row on each worksheet

问题描述

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

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.

例如:如果工作簿包含8个工作表，每个工作表中有200行，则结果将是200个工作簿，其中包含8个工作表，其中1行.

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.

源工作簿

结果工作簿(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

推荐答案

您找到解决问题的方法了吗?如果没有，我建议以下内容:

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

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

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.

这篇关于将数据从具有多个工作表的工作簿复制到多个新工作簿中，每个工作表上仅一行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！