エクセル_行で分割する方法

質問

35000人分の住所録を4000人分ずつに分割したいと思います。
良い方法はありませんでしょうか？
最終的には、4000人分ずつのデータが入った9枚のエクセルファイルを
つくりたいです。
関数もマクロも全く詳しくありません。よろしくお願いいたします。

回答No.2

K Kazz（@JazzCorp）

'マスタファイルを、指定された行数で分割して複数のファイル（ブック）にする
'結果はマクロブックと同じフォルダに出る
'マクロブックは、マスタファイルと同じフォルダに入れる
'マクロブックに指示書（ブック名とシート名の対応）を書いて、アクティブシートにして実行
'１行目にマスタの情報（A１：ブック名：拡張子も必要、B１：シート名）
'２行目以降に分割後のファイルの情報（ブック名とシート名のセット）
'環境に依存するところは適当に変更する
Option Explicit
Sub DivideRobo()
Const xUnits = 4000 '分割行数
Const xHeads = 1 '見出しの行数
Dim xSheet As Worksheet
Dim xRange As Range
Dim xPath As String
Dim xPath_M As String
Dim xMaster As String
Dim xNames() As String
Dim xName As String
Dim xLast As Long
Dim xLast_M As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
On Error Resume Next
Debug.Print vbNewLine & Now & " ：Here We 50！"
' Application.ScreenUpdating = False
Application.DisplayAlerts = False
'マクロを実行したときのシートにブック名とシート名の対応が設定されている
Set xSheet = ThisWorkbook.ActiveSheet
xName = xSheet.Name
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
ReDim xNames(xLast + 1)
xMaster = xSheet.Range("B1").Value
Worksheets(xMaster).Delete
xPath = (ThisWorkbook.Path & "\")
ChDir xPath
'マスタの存在を確認
xPath_M = (xPath & xSheet.Range("A1").Value)
If (Dir(xPath_M, vbNormal) <> Empty) Then
With Workbooks.Open(xPath_M)
'マスタをマクロブックにコピー
Debug.Print xMaster
.Worksheets(xMaster).Copy After:=ThisWorkbook.Worksheets(xName)
'マスタよ！サヨウナラ、、、
.Close (False)
End With
'アクティブシートは、コピーしたマスタ
Set xSheet = ThisWorkbook.Worksheets(xName)
' ThisWorkbook.Worksheets(xSheet.index+1).Activate
xLast_M = Cells(Rows.Count, "A").End(xlUp).Row
Debug.Print xLast_M
nn = 1
For kk = 2 To xLast
If Not IsEmpty(xSheet.Cells(kk, "A")) Then
Debug.Print nn
If (nn < xLast_M) Then
xNames(kk) = xSheet.Cells(kk, "B").Value
Debug.Print xNames(kk)
Worksheets(xNames(kk)).Delete
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = xNames(kk)
With Worksheets(xMaster)
Application.CutCopyMode = False
.Rows(1 & ":" & xHeads).Copy
Cells(1, "A").PasteSpecial Paste:=xlPasteAll
' mm = xUnits * (kk - 2) + xHeads + 1
mm = nn + 1
nn = mm + xUnits - 1
If (nn > xLast_M) Then
nn = xLast_M
End If
Application.CutCopyMode = False
Debug.Print mm & "：" & nn
.Rows(mm & ":" & nn).Copy
With Cells(Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
' .PasteSpecial xlPasteValuesAndNumberFormats
'Excel2000はコォ～なっちゃう、、、
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
'引数を省略すると新規ブックが自動的に開いてシートがコピーされ、新規ブックがアクティブになる
Worksheets(xNames(kk)).Move
'保存して閉じる
xNames(kk) = xSheet.Cells(kk, "A").Value
Debug.Print xNames(kk)
ActiveWorkbook.SaveAs (xPath & xNames(kk))
ActiveWorkbook.Close (False)
End With
End If
End If
Next
Else
MsgBox "File not found !!"
End If
ThisWorkbook.Worksheets(xName).Select
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。
エクセルも関数もマクロも全く分からず…
勉強しながらやってみます。