每N行创建一个新工作表的Excel宏

Question

我正尝试编写一种宏来将Excel文件的几千行拆分成每个工作表250行的工作表，不包括原始标题行，该行也应复制到每个工作表中。总共有13列，有些字段为空。

我可以自己对文档进行排序 - 这不是问题 - 只是我没有宏技能来解决这个问题。

我已经尝试搜索并找到了一些示例，但都不太适合..例如这个.. 创建将Excel行从单个工作表转换为新工作表的宏 ..或者这个.. 将从一个工作表输入的数据保存到另一个工作表的连续行中的Excel宏

有什么帮助吗？

- Noah

Answer 1

@pnuts提供的Jerry Beaucaire的解决方案完美地解决了问题。

https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows

Option Explicit

Sub SplitDataNrows()
'Jerry Beaucaire,  2/28/2012
'Split a data sheet by a variable number or rows per sheet, optional titles
Dim N As Long, rw As Long, LR As Long, Titles As Boolean

    If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
                "Confirm") = vbNo Then Exit Sub
    N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
    If N = 0 Then Exit Sub
    If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
                "Titles?") = vbYes Then Titles = True

    Application.ScreenUpdating = False
    With ActiveSheet
        LR = .Range("A" & .Rows.Count).End(xlUp).Row

        For rw = 1 + ---Titles To LR Step N
            Sheets.Add
            If Titles Then
                .Rows(1).Copy Range("A1")
                .Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
            Else
                .Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
            End If
            Columns.AutoFit
        Next rw

        .Activate
    End With
    Application.ScreenUpdating = True

End Sub

--

Option Explicit

Sub SplitWorkbooksByNrows()
'Jerry Beaucaire,  2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range

srcPATH = "C:\Path\To\Source\Files\"            'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\"          'remember the final \ in this string
                                                'determine how many rows per sheet to create
    N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
    If N = 0 Then Exit Sub                      'exit if user clicks CANCEL
                                                'Examples of usable ranges:  A:A    A:Z   C:E   F:F
    Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
    If Cols = "False" Then Exit Sub             'exit if user clicks CANCEL
                                                'prompt to repeat row1 titles on each created sheet
    If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
                "Titles?") = vbYes Then Titles = True

    Application.ScreenUpdating = False          'speed up macro execution
    Application.DisplayAlerts = False           'turn off system alert messages, use default answers
    fNAME = Dir(srcPATH & "*.xlsx")             'get first filename from srcPATH

    Do While Len(fNAME) > 0                     'exit loop when no more files found
        Set wbDATA = Workbooks.Open(srcPATH & fNAME)        'open found file
        With ActiveSheet
            LR = Intersect(.Range(Cols), .UsedRange).Rows.Count             'how many rows of data?
            If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
            For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
                Cnt = Cnt + 1                   'increment the sheet creation counter
                Sheets.Add                      'create the new sheet
                If Titles Then titleRNG.Copy Range("A1")    'optionally add the titles
                                                'copy N rows of data to new sheet
                Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
                ActiveSheet.Columns.AutoFit     'cleanup
                ActiveSheet.Move                'move created sheet to new workbook
                                                'save with incremented filename in the destPATH
                ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
                ActiveWorkbook.Close False      'close the created workbook
            Next rw                             'repeat with next set of rows
        End With
        wbDATA.Close False                      'close source data workbook

        fNAME = Dir                             'get next filename from the srcPATH
    Loop                                        'repeat for each found file

    Application.ScreenUpdating = True           'return to normal speed
    MsgBox "A total of " & Cnt & " data files were created."        'report
End Sub

- Noah

Answer 2

这应该能提供你所寻找的解决方案。当我正在输入时，你实际上已经添加了你的答案，但也许有人会觉得它有用。

这种方法只需要你输入每页要复制的行数，并假设在执行时你处于“主”页面。

Sub AddSheets()
Application.EnableEvents = False

Dim wsMasterSheet As Excel.Worksheet
Dim wb As Excel.Workbook
Dim sheetCount As Integer
Dim rowCount As Integer
Dim rowsPerSheet As Integer

Set wsMasterSheet = ActiveSheet
Set wb = ActiveWorkbook

rowsPerSheet = 5
rowCount = Application.CountA(Sheets(1).Range("A:A"))
sheetCount = Round(rowCount / rowsPerSheet, 0)

Dim i As Integer

For i = 1 To sheetCount - 1 Step 1
With wb
    'Add new sheet
    .Sheets.Add after:=.Sheets(.Sheets.Count)

     wsMasterSheet.Range("A1:M1").EntireRow.Copy Destination:=Sheets(.Sheets.Count).Range("A1").End(xlUp)       

    wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Cut Destination:=Sheets(.Sheets.Count).Range("A" & Rows.Count).End(xlUp).Offset(1)
    wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Delete

    ActiveSheet.Name = "Rows " + CStr(((.Sheets.Count - 1) * rowsPerSheet + 1)) & " - " & CStr((.Sheets.Count * rowsPerSheet))
End With


Next

wsMasterSheet.Name = "Rows 1 - " & rowsPerSheet

Application.EnableEvents = True

End Sub

- joshua9k