Excelmacros每n行创build一个新表

我试图编写一个macros来获取几千行的excel文件，并将原始表单的行分成每张 250行的表单，而不包括原始表头行，这也应复制到每个表单中。 总共有13列，有些领域是空的。

我可以自己sorting文件 – 这不是问题 – 我只是没有macros观技能来解决这个问题。

我已经尝试过search，并find了一些例子，但没有一个非常适合..例如这个.. 创buildmacros，将excel行从单张转换为新的工作表 ..或这一个.. 保存从一张纸input数据到另一张纸上的连续行上

任何帮助？

Answer 1

Jerry Beaucairebuild议的解决scheme@ pnuts完美的工作。

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:AA:ZC:EF: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

这应该提供您正在寻找的解决scheme。 您实际上是在input时添加了答案，但也许有人会发现它有用。

此方法只需要input要复制到每个页面的行数，并假设您在执行该操作时位于“主”页面上。

 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