Question

我正在尝试编写一个宏来获取几千行的excel文件，并将初始工作表的行拆分为每张250行的表，不包括原始标题行，也应该复制到每张纸上。总共有13列，有些字段是空的。

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

我已经尝试过搜索，并找到了一些例子，但没有一个非常合适......就像这一个...... create macro that will convert excel rows from single sheet to new sheets ..或者这个...... Save data input from one sheet onto successive rows in another sheet

任何帮助？

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

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

Excel宏每隔n行创建一个新工作表

2 个答案: