Excelのデータを分割したい（マクロ、VB）

Excslのデータを分割したいです。

以下のように、A列が66666であるタイトル行とそのデータが、1つのブックに連続して入力されているファイルがあります。
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
66666 0101 10 5101 0 6
51021906 2 2 200 1385 1010
51021912 2 2 200 1385 1010
・・・
66666 0102 37 5102 0 6
51031806 2 2 57 1583 1002
51031812 2 2 60 1594 1002
51031818 2 2 64 1604 1000
・・・
66666 0103 36 5103 0 6
51041500 2 2 80 1515 1002
51041506 2 2 83 1503 1002
・・・
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
行数は70000行あります。

これを、タイトル行で区切って、新たなブックを作成したいです。
その際、新たなブックの名前もつけたいです。

つまり、以下のように新たなブックを作成したいです。

ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
ブック名：0101
ファイルの中身：
51021906 2 2 200 1385 1010
51021912 2 2 200 1385 1010
・・・
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
ブック名：0102
ファイルの中身：
51031806 2 2 57 1583 1002
51031812 2 2 60 1594 1002
51031818 2 2 64 1604 1000
・・・
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ
ブック名：0103
ファイルの中身：
51041500 2 2 80 1515 1002
51041506 2 2 83 1503 1002
・・・
ｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰｰ

各ブックの行数は異なります。

よろしくお願い致します。

No.1 回答者： googoo900 回答日時： 2016/01/05 00:32

元データのファイルがアクティブな状態でマクロを実行してください。

ファイルは元データと同じフォルダに保存されます。
ファイル名の重複があった場合、保存しますか？のメッセージがでます。同じファイル名がないようにして実行したほうがよいです。
ファイルの保存を繰り返すので、誰が書いたコードでも時間がかかります。ファイル数がいくつになるのかわかりませんが、70000行もあれば相当時間がかかると予想されます。サンプルデータでは作動確認済みですが、事前にデータ数(保存されるファイル数)を減らして試してみたほうがよいと思います。
また、コピペを繰り返すのでメモリ不足のエラーがでる可能性があります。元データとマクロ以外のファイルは立ち上げずに、メモリに余裕のあるパソコンで実行されることをおススメします。

概要説明
"66666"を検索して、検索n回目の行と検索(n+1)回目の行の間をコピーして新規ブックにペーストして保存しています。
検索(n+1)回目の行がn回目の行よりも小さくなったら終了させています。

Sub Macro_DataSeparate()
Dim FoundCell As Range 'またはバリアント型(Variant)とする
Dim r1, r2 As Integer 'データ範囲
Dim EndFlag As Integer
Dim DataPath As String
DataPath = ActiveWorkbook.Path
Set FoundCell = Columns("A:A").Find(What:="66666", After:=Cells(Rows.Count, 1))
Do
If FoundCell Is Nothing Then
MsgBox "検索しましたが、見つかりませんでした"
EndFlag = 1
Exit Do
ElseIf FoundCell.Row < r2 Then
EndFlag = 1
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Else
FoundCell.Select
End If
r1 = Selection.Row
If r2 <> 0 Then
Range(Rows(r1 - 1), Rows(r2)).Copy
Workbooks.Add
Range("a1").Select
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=DataPath & "\" & Cells(1, 2).Value & ".xlsx"
ActiveWorkbook.Close
End If
r2 = r1
Set FoundCell = Columns("A:A").FindNext(After:=Cells(r2, 1))
Loop Until EndFlag = 1
End Sub

この回答へのお礼

実行してみたところ、分割したファイルが作成されました。
しかし各ファイルの1行目にタイトル行も含まれてしまいました・・・。

今回は他の方が作成してくださったマクロで解決できましたので、こちらのご回答はまた次回に活かしたいと思います。
ご回答くださりありがとうございました！

お礼日時：2016/01/06 21:45

No.2 ベストアンサー 回答者： 30246kiku 回答日時： 2016/01/05 16:11

雰囲気以下でどうなりますか

処理の流れは
・アクティブシートの A,B 列を配列に読み込み
・66666 が見つかったら
　コピーする A列の範囲を Dictionary の値として覚えます
　その時のキーは、66666 右横の値
※ 66666 右横の値が重複して出現した時には、後をスキップします
・何ファイルになるのかを求めて、お伺いを立てて
・出力先フォルダを指定してもらって
・新規ブックを開いて
・・シートをクリアして
・・Dictionary の各値の 6 列分をコピーして
・・名前を変更して保存して
この・・を覚えた分繰り返します
・ブックを閉じて終了

>　　On Error Resume Next
これは、名前を変えて保存する時、
既にファイルが存在したらメッセージが出ますが、
置き換え以外を選択すると、そこで止まってしまうのを回避するため


Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant, v As Variant
　　Dim sPath As String, sMsg As String
　　Dim i As Long, j As Long
　　Const CCHK As Long = 66666
　　Const CMSG As String = "{%1} ファイルになります" _
　　　　　　& vbCrLf & "作成しますか？"

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　　　vA = .Resize(, 2).Value
　　　　i = 1
　　　　Do While (i <= UBound(vA))
　　　　　　If (vA(i, 1) = CCHK) Then Exit Do
　　　　　　i = i + 1
　　　　Loop
　　　　While (i <= UBound(vA))
　　　　　　j = 1
　　　　　　Do While ((i + j) <= UBound(vA))
　　　　　　　　If (vA(i + j, 1) = CCHK) Then Exit Do
　　　　　　　　j = j + 1
　　　　　　Loop
　　　　　　If ((j > 1) And (Not dic.Exists(vA(i, 2)))) Then
　　　　　　　　dic.Add vA(i, 2), .Cells(i + 1).Resize(j - 1)
　　　　　　End If
　　　　　　i = i + j
　　　　Wend
　　End With

　　sMsg = Replace(CMSG, "{%1}", dic.Count)
　　If (MsgBox(sMsg, vbYesNo + vbQuestion) <> vbYes) Then
　　　　Set dic = Nothing
　　　　Exit Sub
　　End If

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If (Not .Show) Then
　　　　　　Set dic = Nothing
　　　　　　Exit Sub
　　　　End If
　　　　sPath = .SelectedItems(1) & "\"
　　End With

　　On Error Resume Next
　　Application.ScreenUpdating = False
　　With Workbooks.Add
　　　　With .Worksheets(1)
　　　　　　For Each v In dic.Keys
　　　　　　　　.Cells.Clear
　　　　　　　　dic(v).Resize(, 6).Copy .Range("A1")
　　　　　　　　.Parent.SaveAs sPath & v
　　　　　　Next
　　　　End With
　　　　.Close False
　　End With
　　Application.ScreenUpdating = True

　　Set dic = Nothing
End Sub

この回答へのお礼

実行してみたところ、無事に作成できました。とても助かりました。
ありがとうございました！

お礼日時：2016/01/06 21:46

No.3 回答者： googoo900 回答日時： 2016/01/10 13:13

No.1です。

解決したように思いますが、一応修正しました。
コピー範囲が、はじめの1行分だけ広かったのが原因です。質問文をよく読んでなかったんでしょうね。

Sub Macro_DataSeparate()
Dim FoundCell As Range 'またはバリアント型(Variant)とする
Dim r1, r2 As Integer 'データ範囲
Dim EndFlag As Integer
Dim DataPath As String
Dim SavaName As String

Application.ScreenUpdating = False
DataPath = ActiveWorkbook.Path
Set FoundCell = Columns("A:A").Find(What:="66666", After:=Cells(Rows.Count, 1))
Do
If FoundCell Is Nothing Then
MsgBox "検索しましたが、見つかりませんでした"
EndFlag = 1
Exit Do
ElseIf FoundCell.Row < r2 Then
EndFlag = 1
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Else
FoundCell.Select
End If
r1 = Selection.Row
If r2 <> 0 Then
SavaName = Cells(r2, 2).Value
Range(Rows(r1 - 1), Rows(r2 + 1)).Copy
Workbooks.Add
Range("a1").Select
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:=DataPath & "\" & SavaName & ".xlsx"
ActiveWorkbook.Close
End If
r2 = r1
Set FoundCell = Columns("A:A").FindNext(After:=Cells(r2, 1))
Loop Until EndFlag = 1
Application.ScreenUpdating = true
End Sub

No.4 回答者： 30246kiku 回答日時： 2016/01/11 13:19

＃２です

気を悪くされたらごめんなさい

> Dim r1, r2 As Integer

この部分は、以下と同じ？

Dim r1 As Variant, r2 As Integer

> 行数は70000行あります。
より

Dim r1 As Long, r2 As Long

が良いかも？です

似た処理で記述してみました


Public Sub Samp2()
　　Dim r1 As Range, r2 As Range
　　Dim sPath As String
　　Dim bGo As Boolean
　　Const CCHK As Long = 66666

　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If (Not .Show) Then Exit Sub
　　　　sPath = .SelectedItems(1) & "\"
　　End With

　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False
　　With Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　　　bGo = True
　　　　Set r1 = .Cells(.Rows.Count)
　　　　Set r2 = .Find(CCHK, r1, LookAt:=xlWhole)
　　　　While ((Not r2 Is Nothing) And (bGo))
　　　　　　Set r1 = r2
　　　　　　Set r2 = .FindNext(r1)
　　　　　　If (r1.Row >= r2.Row) Then
　　　　　　　　Set r2 = .Cells(.Rows.Count).Offset(1)
　　　　　　　　bGo = False
　　　　　　End If
　　　　　　If (r2.Row - r1.Row > 1) Then
　　　　　　　　With Workbooks.Add
　　　　　　　　　　Range(r1.Offset(1), r2.Offset(-1)) _
　　　　　　　　　　　　.Resize(, 6).Copy .Worksheets(1).Range("A1")
　　　　　　　　　　.SaveAs sPath & r1.Offset(, 1).Value
　　　　　　　　　　.Close False
　　　　　　　　End With
　　　　　　End If
　　　　Wend
　　End With
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub


※
> 　　Application.DisplayAlerts = False
を追加して、同じファイル名があった際には、強制上書きするように
（上書きしますか？メッセージは出てこない）

Resize(, 6)　で、６列分を Copy してましたが、
EntireRow　に変更すると、その行全部になります

※
・都度、新規ファイルを Add / Close した方が良いのか、
・使いまわしした方が良いのか
どちらが軽い処理なのかわかりません
５０ファイル程度で、Samp1 / Samp2 さほど時間差ないみたい･･･


以下は簡易確認用データ作成（A,B列だけの）

Public Sub testData()
　　Dim i As Long, j As Long, k As Long
'　　Const CLINES As Long = 70000
　　Const CLINES As Long = 2000
　　Const CCHK As Long = 66666

　　Randomize
　　Application.ScreenUpdating = False
　　Cells.Delete
　　i = 1
　　k = 101
　　While (i <= CLINES)
　　　　With Cells(i, "A").Resize(, 2)
　　　　　　.Value = Array(CCHK, k)
　　　　　　For j = 1 To Int(100 * Rnd()) + 1
　　　　　　　　With .Offset(j)
　　　　　　　　　　.Value = Array(k, .Address(False, False))
　　　　　　　　End With
　　　　　　Next
　　　　　　i = i + j
　　　　　　k = k + 1
　　　　End With
　　Wend
　　Application.ScreenUpdating = True
End Sub