エクセルで50行ごとに区切ったデータをシートに分割したい

質問

エクセルで2000行ほどある一枚のシートを50行ごとに
(1-50)(51-100)(101-150)…と分割して、一つずつ
新しいブックで保存する作業があります。

今までは50行ごとにコピーして新しいブックにペーストを
繰り返してましたが、大量にきたもので困ってます。
何か自動化などできないことでしょうか？
ご回答お待ちしております。

参考にシートは以下のような形式です。
　　Ａ　　Ｂ　　Ｃ　　Ｄ
１　 a　　1　　　1　　1
２　 b　　1　　　2　　3
３　 c　　2　　　3　　4
４　 d　　5　　　6　　7
５　 e　　7　　　8　　9
６　 f　　2　　　3　　4　
７　 h　　5　　　6　　7
８　 g　　8　　　9　　1
９　 n　　2　　　3　　4
１０ n　　5　　　6　　7
・
・
・
５０ j　　5　　　6　　7

回答No.2

KenKen_SP · ベストアンサー

> エクセルで50行ごとに区切ったデータをシートに分割したい
> …と分割して、一つずつ新しいブックで保存する作業があります。

「ブック」と「シート」のどちらか不明瞭ですが、アクティブシートを50行毎に
新しいブックにコピーするコードです。

アクティブブックと同じフォルダに保存されます。

Option Explicit

Sub Sample()

　　Dim Wb　　　　　As Workbook
　　Dim rngData　　 As Range
　　Dim i　　　　　 As Long
　　Dim strBasename As String
　　Dim strFilename As String
　　Dim lng1stRow　 As Long
　　Dim lngLstRow　 As Long

　　Const STEP_ROWS_COUNT = 50 '50 行

　　Set rngData = ActiveSheet.UsedRange
　　strBasename = ActiveWorkbook.FullName

　　With rngData
　　　　lng1stRow = .Row
　　　　lngLstRow = Application.Ceiling(.Cells(.Cells.Count).Row, STEP_ROWS_COUNT)
　　End With
　　Application.ScreenUpdating = False
　　For i = lng1stRow To lngLstRow Step STEP_ROWS_COUNT
　　　　' 新規ブック作成
　　　　Set Wb = Workbooks.Add
　　　　' STEP_ROWS_COUNT で指定された行ごとに新規ブックの Sheet1 にコピー
　　　　rngData.Rows(CStr(i) & ":" & CStr(i + STEP_ROWS_COUNT - 1)).Copy _
　　　　　　Destination:=Wb.Worksheets("Sheet1").Range("A1")
　　　　' 新規ファイル名生成
　　　　strFilename = Left$(strBasename, InStrRev(strBasename, ".") - 1) & "(" _
　　　　　　　　　　& Format$(i, "0000") & "-" & Format$(i + STEP_ROWS_COUNT - 1, "0000") _
　　　　　　　　　　& ").xls"
　　　　' 同一フォルダに保存して閉じる
　　　　Wb.SaveAs Filename:=strFilename
　　　　Wb.Close
　　　　Set Wb = Nothing
　　Next i
　　Set rngData = Nothing

End Sub

お礼

マクロがよく分からないので、悪戦苦闘のうえ、
無事に成功できました。凄いですね！

ファイルが番号順の名前で出来てきたときは
驚きと嬉しさでいっぱいでした。
マクロを作っていただき大変助かりました。

ほんとうに有難うございました。

回答No.1

o_chi_chi

以下のようなマクロで可能です。
対象のシートは１枚であると仮定しています。
(あまりテストしてないのでバグがあるかもしれません）
---
Sub test()
Dim m As Long
Dim r As Long
Dim n As String
n = ActiveWorkbook.Name
'コピー単位
m = 50
'最終行取得
r = Range("A65536").End(xlUp).Row
'最終行がコピー単位より大きい間繰り返し
Do While r > m
'コピー単位より大きい部分を切り取り
Rows(CStr(m + 1) & ":" & CStr(r)).Cut
'新しいシートを作成
Sheets.Add After:=Worksheets(Worksheets.Count)
'新しいシートに貼り付け
Rows("1:1").Insert Shift:=xlDown
'最終行を取得
r = Range("A65536").End(xlUp).Row
Loop
'シートが1つになるまで繰り返し
Do While Worksheets.Count > 1
'最後のシートを新しいブックに移動
Sheets(Worksheets.Count).Move
'最初のブックに戻る
Windows(n).Activate
Loop
End Sub

お礼

マクロはよく分からないんですが、ちょっとうまく
動いてくれませんでした。途中で止まりました。
どこが悪いかもよく分かりませんが、
お手数かけて
作っていただき有難うございました。