数千行の Excel ファイルを取得し、最初のシートの行をシートごとに 250 行のシートに分割するマクロを作成しようとしています。元のヘッダー行は含まれません。これも各シートにコピーする必要があります。合計 13 列あり、一部のフィールドは空です。
私は自分でドキュメントを並べ替えることができます - それは問題ではありません - 私はこれを理解するためのマクロスキルを持っていません.
私は検索を試み、いくつかの例を見つけましたが、どれも完全に適合しません..このよう な..単一シートから新しいシートにExcel行を変換するマクロを作成します..またはこれ..1つのシートからのデータ入力を保存します別のシートの連続する行に
何か助けはありますか？
Jerry Beaucaireによる@pnutsの提案されたソリューションは完全に機能しました。
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