エクセルＶＢＡでブックの分割

質問

下記のようなデータがあります。

支店code 顧客名 属性 顧客コード
A01 ああああ 1 0123456
A01 いいいい 1 0123457
A01 うううう 2
A01 ええええ 1 0123459
A55 かかかか 1
A55 きききき 2 0123461
A55 くくくく 3 0123462
B22 ささささ 4 0123463
B22 しししし 1 0123464
C56 たたたた 2 0123465
D88 なななな 1 0123466

全部で約800件ほどです。実際には顧客コード以降にも多くのデータがあります。
これを支店コードごとに別ブックに分割し、さらに顧客コードごとにそれぞれ別シートにしたいのです。（シート名は顧客名）
中には顧客コードが未記入のものがあり、その場合はそのデータは無視します。

とても手におえません。お助けいただけると幸いです。

回答No.8

sakenomo · ベストアンサー

＃４です。

> これには定義はないのでしょうか？

ChDir myPath があるので、ファイルのフォルダ名は省略しました。

ただ、数字だけの支店名で起こるエラーは、以下の方法で解決できそうですが、ファイル名にフォルダ名も含めなければならないようで、ChDir myPath　は、削除してもよさそうです。

ブック作成での、

ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Value & ".xls" 　を

ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Text & ".xls"

に。支店ブックを開く時の、

Workbooks.Open c.Value & ".xls" 　を

Workbooks.Open myPath & c.Text & ".xls"

に変更してみてください。

あと、気になっていたのですが、最後のほうの

If c.Value = "" Then Exit For

は、いらなかったですね。他にもヘンなところがあるかと思いますが、大目に見てやってください。

補足

ありがとうございました。
支店コードが数字のみでも出来るようになりました。

あと、
For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"

ですが、この　c　とはdSheet.Range("A1").CurrentRegion 内のセルという意味ですか？

その場合 Dim c As　～　とかの記述は必要ではないのですかという質問だったのですが。（For Each c In　というのは今まで使ったことがないもので。不勉強ですみません）

回答No.9

sakenomo

> その場合 Dim c As　～　とかの記述は必要ではないのですか

必要です。Dim c As Range　ですね。
書き忘れてました。(^_^;)

変数を型を指定して宣言しておくと、エラーの原因を見つけやすくなり、変数の型（データ型）の種類によっては処理速度が速くなったりするそうです。

モジュールの先頭で　Option Explicit　ステートメントを書いておけばいいのですが、ズボラな僕は書かないことが多いので、こういう事になります。

お礼

大変ありがとうございました。

おかげでこちらの加工もうまく出来ました。
大変勉強させていただき、またお助けいただき、感謝感激です。
これからもよろしくお願い致します。

回答No.7

Silent-G

続きです。

IDX_R = 1 'インデックスの初期設定
Do Until IDX_R >= UBound(wData, 1) '最終行になったらループを抜ける（条件１）
'---------------------------------------------第１ループ---------------------------------------------
'第１ループ前処理
ShitenKey = wData(IDX_R, 1) '支店キーの設定
Workbooks.Add '新しいブックを作成
Set wNewBook = ActiveWorkbook '新しいブックをwNewBookに設定
Set wCurrentSheet = ActiveSheet '新しいブックのアクティブシートをwCurrentSheetに設定（これが貼り付け対象のシート）
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) '（条件１）又は、支店が変わったら（条件２）ループを抜ける
'---------------------------------------------第２ループ---------------------------------------------
'第２ループ前処理
KokyakuKey = wData(IDX_R, 4) '顧客コードキーの設定
With wCurrentSheet
.Name = KokyakuKey 'シート名を顧客コードにする
.Range(.Cells(1, 1), .Cells(1, 4)).Value = wTitle '1行目にタイトルを設定
End With
CurrentRow = 2 'データを貼り付ける行の初期値設定 '
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) Or _
KokyakuKey <> wData(IDX_R, 4) '（条件１）又は、（条件２）又は、顧客コードが変わったら
'---------------------------------------------第３ループ---------------------------------------------
'第３ループ処理
With wCurrentSheet
.Range(.Cells(CurrentRow, 1), .Cells(CurrentRow, 4)).Value = Array( _
wData(IDX_R, 1), wData(IDX_R, 2), wData(IDX_R, 3), wData(IDX_R, 4))
'↑データの貼り付け（１～４カラムに1度に値を設定しています）
'＊＊＊関数を入れるとしたらこのあたりでしょう＊＊＊
End With
IDX_R = IDX_R + 1 'データインデックスのカウントアップ
CurrentRow = CurrentRow + 1 'データを貼り付ける行のカウントアップ
'---------------------------------------------第３ループ---------------------------------------------
Loop
'第２ループ後処理
With wNewBook
.Sheets.Add After:=.Sheets(.Sheets.Count) '新しいシートを作成
End With
Set wCurrentSheet = ActiveSheet 'アクティブシートをwCurrentSheetに設定（貼り付け対象シートの切り替え）
'---------------------------------------------第２ループ---------------------------------------------
Loop
'第１ループ後処理
Application.DisplayAlerts = False 'アラートが出ないようにする
wCurrentSheet.Delete '余分なシートの削除
Application.DisplayAlerts = True 'アラートが出るようにする
With wNewBook
.Sheets(1).Activate '1枚目のシートをアクティブにする。
.SaveAs SavePath & wNow & ShitenKey & ".xls" 'ブックの保存(重複しないように、最初に取得した時刻をファイル名に含める)
.Close 'ブックを閉じる
End With
'---------------------------------------------第１ループ---------------------------------------------
Loop

ここの処理は#2の方が説明されている文章をコード化したものです。
１行目から順番に読み込んでキーが変わったら（ブレイクしたら）何らかの
処理をする。といった感じです。
３重のループを使用していて文章で説明するより各行のコメントを参考にした方が
わかりやすいと思います。（手抜き？^^;）
※ここは、特にHTMLソースを見た方がわかりやすいですよ。

というわけで、説明はこれくらいで・・・
わかりにくい説明があったら指摘してくださいね。

では、いい仕事してくださいね！

お礼

ありがとうございました！
解説を読んで勉強したいと思います。
これからもよろしくお願いします。

回答No.6

Silent-G

こんにちは。
コメントなしの読み辛いソースですみませんでした。
ご存知だとはかもしれませんが、ソースはページをそのままコピーするより
ソースから拾い出してエディタでタグとか記号を変換したほうが字下げがある
ので少しは読みやすいですよ。

では、かいつまんで説明しますね。
With Application
.ScreenUpdating = False
wSheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With
ここでは、画面の更新を止めて、新しくブックを開いた時に１つだけ
シートを開くように設定しています。設定の前に、
wSheetsInNewWorkbook = .SheetsInNewWorkbook
としているのは現在の設定を保存して最後に戻す為です。
ただし、エラー処理を考慮していないので途中でエラーになって止まって
しまったときやマクロの実行を強制的に止めた時などは手動で設定し直さ
なければなりません。この点は改善の余地ありです。

Sheets(1).Copy After:=Sheets(1)
Set wSheet = ActiveSheet
ここでは、ソートする為の前処理としてデータのあるシートをコピーして
元のデータが残るようにしています。そして以降ソートするページをわかりやすく
するために、オブジェクト変数のwSheetにSetしています。
ただし（また^^;）、前提として１枚目のシートにデータがあると仮定しているので、
Const wDataSheetName As String = "データシート"
Sheets(wDataSheetName).Copy After:=Sheets(wDataSheetName)
みたいな感じで記述した方がシート名が変わった時もConst宣言を変更するだけでいいので
保守性がよくなると思います。（改善点２）

次はソートの部分です。
最初の投稿時にも書きましたがエクセルらしいやり方です。（と勝手に思ってる^^;）

StartRow = 3
With wSheet
wTitle = .Range(.Cells(2, 1), .Cells(2, 4))
EndRow = .Cells(65536, 1).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 4), Order1:=xlAscending, _
Header:=xlNo
EndRow = .Cells(65536, 4).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 1), Order1:=xlAscending, _
Key2:=.Cells(StartRow, 4), Order2:=xlAscending, _
Header:=xlNo
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
Set wDataRange = Nothing
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Set wSheet = Nothing

ざっと見てもらったら、わかると思いますが２回ソートしています。
最初のソートはデータの３行目から顧客番号の昇順にソートしています。
これは「顧客コードが未記入のものがあり、その場合はそのデータは無視」
と言う条件があるので、未記入のデータを取り除くためです。
コツは最終行の設定方法で、1回目は
EndRow = .Cells(65536, 1).End(xlUp).Row
として、支店が最後に入力されている行を最終行としているのに対して、2回目は
EndRow = .Cells(65536, 4).End(xlUp).Row
として、顧客番号が最後に入力されている行を最終行としているのです。
途中にソートを入れることによって顧客番号が未入力の行は下の方に集まるので
結果として顧客番号未入力のデータは無視されることになるのです。
そして、2回目のソートでは支店、顧客番号の順番にソートし直しています。

ソートが終わったら、
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
バリアント型の変数wDataにソート後の値をすべてぶち込んでいます。
これは、この後の処理でRangeオブジェクトの参照を出来るだけ減らす事によって
処理速度を改善するためです。
ここの注意点は最終行を"EndRow + 1"として1行余分にデータを取り込むことによって
以降の処理でテーブルオーバーを起こさないようにすることです。

----------------------
長いので、いったん投稿します。

回答No.5

Silent-G

おもしろそうなので、作ってみました。
ちょっと、ややこしいですが・・・
でも、処理は早いと思いますよ。

ソートの部分はExcelらしくしましたが、
分割部分はただのコントロールブレイクです。

調子に乗って作ってたら遅くなってしまったので
コメントと解説は省きます。
(フォローできる方がいたらお願いします)
暫くクローズせずにおいといてもらえるなら、
明日か明後日にでも補足します。

-----------------------------------------------
Private Sub XXX()
Dim wNewBook As Excel.Workbook
Dim wCurrentSheet As Excel.Worksheet
Dim wSheet As Excel.Worksheet
Dim wDataRange As Excel.Range

Dim wNow As String
Dim wSheetsInNewWorkbook As Long
Dim wTitle As Variant
Dim wData As Variant
Dim IDX_R As Long
Dim StartRow As Long
Dim EndRow As Long
Dim CurrentRow As Long

Dim ShitenKey As String
Dim KokyakuKey As String

Const SavePath As String = "D:\temp\"

With Application
.ScreenUpdating = False
wSheetsInNewWorkbook = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
End With

Sheets(1).Copy After:=Sheets(1)
Set wSheet = ActiveSheet
wNow = Format$(Now, "YYYY-MM-DD-HH-NN-SS_")

StartRow = 3
With wSheet
wTitle = .Range(.Cells(2, 1), .Cells(2, 4))
EndRow = .Cells(65536, 1).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 4), Order1:=xlAscending, _
Header:=xlNo
EndRow = .Cells(65536, 4).End(xlUp).Row
Set wDataRange = .Range(.Cells(StartRow, 1), .Cells(EndRow, 4))
wDataRange.Sort _
Key1:=.Cells(StartRow, 1), Order1:=xlAscending, _
Key2:=.Cells(StartRow, 4), Order2:=xlAscending, _
Header:=xlNo
wData = .Range(.Cells(StartRow, 1), .Cells(EndRow + 1, 4))
Set wDataRange = Nothing
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
Set wSheet = Nothing

IDX_R = 1
Do Until IDX_R >= UBound(wData, 1)
ShitenKey = wData(IDX_R, 1)
Workbooks.Add
Set wNewBook = ActiveWorkbook
Set wCurrentSheet = ActiveSheet
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1)
KokyakuKey = wData(IDX_R, 4)
With wCurrentSheet
.Name = KokyakuKey
.Range(.Cells(1, 1), .Cells(1, 4)).Value = wTitle
End With
CurrentRow = 2
Do Until IDX_R >= UBound(wData, 1) Or _
ShitenKey <> wData(IDX_R, 1) Or _
KokyakuKey <> wData(IDX_R, 4)
With wCurrentSheet
.Range(.Cells(CurrentRow, 1), .Cells(CurrentRow, 4)).Value = Array( _
wData(IDX_R, 1), wData(IDX_R, 2), wData(IDX_R, 3), wData(IDX_R, 4))
End With
IDX_R = IDX_R + 1
CurrentRow = CurrentRow + 1
Loop
With wNewBook
.Sheets.Add After:=.Sheets(.Sheets.Count)
End With
Set wCurrentSheet = ActiveSheet
Loop
Application.DisplayAlerts = False
wCurrentSheet.Delete
Application.DisplayAlerts = True
With wNewBook
.Sheets(1).Activate
.SaveAs SavePath & wNow & ShitenKey & ".xls"
.Close
End With
Loop

With Application
.ScreenUpdating = True
.SheetsInNewWorkbook = wSheetsInNewWorkbook
End With

Set wNewBook = Nothing
Set wCurrentSheet = Nothing

End Sub
-----------------------------------------------

お礼

ありがとうございました。
テストデータでやってみたらうまく行きました。

ただ、実際には分割したブックの各シートにそれぞれ数式を埋め込む作業があるので書いていただいたコードを必死で理解しようとしているところです。
なかなかわかりませんので解説していただけると幸いです。

なお、データは支店コードで順番にならんでいますのでソートは必要ないと思うのですが。

回答No.4

sakenomo

＃３です。

やっぱり＃２さんの方法が、きれいなコードが出来そうですね。
僕のだと顧客コードに重複があると、同じ名前のシートを作ろうとして必ずエラーになります。これを避けようとするとコードが複雑になるし、実行時間も余分にかかることになります。また、同一顧客のデータをシートにまとめるのにも、ソートしてあったほうが楽に出来そうです。

補足

ありがとうございます。だいぶわかってきました。
ただ、

For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"

のところで変数c （支店コードですよね？）がいきなり出てくるのですが、これには定義はないのでしょうか？

それから支店コードがＡ01のような文字列の場合は正常にうごきましたが、335のような数字だとエラーになりました。
どう対処すればいいでしょうか？お教えください。

回答No.3

sakenomo

これだけで実用に耐えられるとは思いませんので、ご参考までに。手を入れやすいように機能別に分けて書いたつもりです。
データ中の顧客コードは、重複は無いものとしています。

Sub test()
Dim dSheet As Worksheet, Siten As Range, i As Long, n As Long
Dim Kyaku As Range, Data As Range, mySh As Worksheet, myPath As String

myPath = "C:\Documents and Settings\Owner\デスクトップ\分割\" '-----パス名を環境に合わせて変更してください。
Application.ScreenUpdating = False
Set Data = Worksheets(1).Range("A1").CurrentRegion
'-------------------------------------------------------------------支店の取得
Set Siten = Data.Columns(1)
Set dSheet = Worksheets.Add(After:=Worksheets(1)) '作業用シート
For i = 3 To Siten.Rows.Count
If Application.WorksheetFunction.CountIf(dSheet.Columns(1), Siten.Rows(i).Value) = 0 Then
n = n + 1
dSheet.Columns(1).Rows(n).Value = Siten.Rows(i).Value
End If
Next
'------------------------------------------------------------------ブック作成
For i = 1 To dSheet.Range("A1").CurrentRegion.Rows.Count
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=myPath & dSheet.Cells(i, 1).Value & ".xls"
ActiveWorkbook.Close SaveChanges:=True
Next
'-------------------------------------------------------------------シート作成
Set Kyaku = Data.Columns(2)
ChDir myPath
For Each c In dSheet.Range("A1").CurrentRegion
Workbooks.Open c.Value & ".xls"
For i = 3 To Kyaku.Rows.Count
If Siten.Rows(i).Value = c.Value And Data.Columns(4).Rows(i).Value <> "" Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Kyaku.Rows(i).Value
ActiveSheet.Range(Data.Address).Rows(1).Value = Data.Rows(i).Value
End If
Next
For Each mySh In Worksheets
Application.DisplayAlerts = False
If Left(mySh.Name, 5) = "Sheet" Then '余分なシートの削除
If ActiveWorkbook.Worksheets.Count <> 1 Then mySh.Delete
End If
Next
ActiveWorkbook.Close SaveChanges:=True
If c.Value = "" Then Exit For
Next
dSheet.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

エクセルの仕様では、ブック中のワークシートの数はメモリに依存すると思いました。数が多くなりそうですが、大丈夫なのでしょうか。

お礼

ありがとうございました。
テストデータでやってみたらうまく行きました。

ただ、実際には分割したブックの各シートにそれぞれ数式を埋め込む作業があるので書いていただいたコードを必死で理解しようとしているところです。
なかなかわかりませんが。

回答No.2

imogasi

これは下記ロジックが単純で、古く（コンピュタ初期から事務計算で）から使われていて最適法と思います。
（１）まず支店コード（第１キー）、顧客コード（第２キー）（必要あれば第３キーを考える）でエクセルでソート
する。（エクセルで幸いソート出来ます。昔はソート・マージプログラムでやりました。）
（２）各行全８００行について、直前の行レコードと比べて、A支店コードが変わったか（不等か）
　　B顧客コードが変わったか（同じでないか）
を見ます（コントロールブレイクという。支店別、顧客別にページ変えをする時必須のテクニックでした）。
直前の行の第１キー、第２キーは変数に記憶します。
（３）支店コードが変わったら、前（現在）のブックはクローズし、新しいブックをオープンします。
行ポインタは、次の第１シートの最初行を指す。
（４）顧客コードが変ったら、別シートに書きに行きます。行ポインタは次のシートの最初行を指す。
（５）骨格だけなら１０行ぐらいかなと思います。
ソートが済むと、総なめ比較をしなくても良いのが重宝するのです。「存在するかチェックする」のところで総なめ
が行われ方法が多いです。これを昔は嫌いました。今はCPUのスピードがUPして、平気化してるようです。

お礼

ありがとうございます。
今回のデータはソートしなくとも順番にならんでいますのでいいと思うのですが、自分ではとてもとても・・・。
お恥ずかしいです。

回答No.1

garyu77

単純に支店Codeだけで分割するなら…
まず、データファイルを格納するフォルダを指定しておきます。
※ その配下にファイル名を支店Codeと同じものにしてファイルを作成していきます。

If文の条件で、支店Codeを抜き出します。
抜き出した支店Codeと同じファイル名が存在するかチェックします。
※ 支店Codeと同名のファイル存在する場合それをオープンする。
※ 支店Codeとして同名ファイルが無い場合は作成してオープンする。

あとは、支店Codeを抜き出した行をオープンしたファイルの最終行に書き込めば完了です。
これを元ファイルの最終行まで繰り返す様にループしてください。

参考URL：

http://www.eastwest-net.co.jp/vba/

補足

さっそくありがとうございます。

自分でもなんとかここまでは出来たのですが、顧客名をシート名にして顧客のデータを１シートづつにする方法が分からないのです。

Sub BUNKATSU_2()
Dim wb As Workbook
Dim StartRow As Integer
Dim EndRow As Integer
Dim 新ファイル名 As String

i = 3 '(2行目までタイトルのため)
StartRow = 3

Do
DoEvents

ThisWorkbook.Activate
If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then

EndRow = i

Range("1:2," & StartRow & ":" & EndRow).Copy

Set wb = Workbooks.Add

wb.Activate
wb.Sheets("Sheet1").Range("A1").Select
ActiveSheet.Paste

Application.CutCopyMode = False

新ファイル名 = Cells(3, 1)

ChDir "C:\Windows\デスクトップ\分割"
ActiveWorkbook.SaveAs FileName:="C:\Windows\デスクトップ\分割\" & 新ファイル名 & ".xls"

ActiveWindow.Close

StartRow = i + 1

End If

i = i + 1

Loop Until (Cells(i, 1).Value = "")

End Sub

これで支店コード名のファイルは出来るのですが・・・。