Excel宏每n行創建新工作表

Question

我試圖編寫一個宏來獲取幾千行的excel文件，並將初始工作表的行分成工作表，每個工作表包含250行，不包括原始標題行，也應該複製到每個工作表。共有13列，一些領域是空的。

我可以自己對文檔進行排序 - 這不是問題 - 我只是沒有掌握這個宏的技能。

我嘗試搜索，並發現了幾個例子，但是沒有相當fit..such這一個.. 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