エクセルでブックの分割をするマクロ？

質問

シート２枚を持つ大きなブックがあります。
1枚目2枚目とも、A列には国名、B列に地名、C列目以降に各種データ（1枚目と2枚目は別のデータ）があります。
全部で国名は約60、地名は1000程度です。

たとえば
A列 B列 C列 D列
日本 東京 1111 1234
日本 札幌 2222 2345
日本 函館 1515 0055
韓国 ソウル 0000 0000
韓国 プサン 3322 2323 のような感じです。

これを国別に別々のブック（それぞれ2枚のシートがある）に切り分けるマクロを教えてください。よろしくお願いします。

回答No.4

ki-aaa · ベストアンサー

エクセル2000で動きましたが・・・

Sub 国別ブック作成()
Dim 元ブック名, 新ブック名 As String
Dim 元ブック最終行1, 元ブック最終行2 As Integer
Dim 元ブック行数1, 元ブック行数2 As Integer
Dim 新ブック行数1, 新ブック行数2 As Integer
Dim wwww As String

元ブック名 = ActiveWorkbook.Name
If Workbooks(元ブック名).Sheets(1).Range("A1") = "" Then Exit Sub
Workbooks.Add
新ブック名 = ActiveWorkbook.Name
Workbooks(元ブック名).Sheets(1).Range("A1:Z1").Copy
Workbooks(新ブック名).Worksheets(1).Activate
Range("A1").Select
ActiveSheet.Paste
元ブック最終行2 = Workbooks(元ブック名).Sheets(2).Range("A65536").End(xlUp).Row
新ブック行数2 = 1

For 元ブック行数2 = 1 To 元ブック最終行2
If Workbooks(元ブック名).Sheets(1).Range("A1") = _
Workbooks(元ブック名).Sheets(2).Range("A" & 元ブック行数2) Then
Workbooks(元ブック名).Sheets(2).Range _
("A" & 元ブック行数2 & ":Z" & 元ブック行数2).Copy
Workbooks(新ブック名).Worksheets(2).Activate
Range("A" & 新ブック行数2).Select
ActiveSheet.Paste
新ブック行数2 = 新ブック行数2 + 1
End If
Next 元ブック行数2

新ブック行数1 = 2
元ブック最終行1 = Workbooks(元ブック名).Sheets(1).Range("A65536").End(xlUp).Row

For 元ブック行数1 = 2 To 元ブック最終行1
If Workbooks(元ブック名).Sheets(1).Range("A" & 元ブック行数1) <> _
Workbooks(元ブック名).Sheets(1).Range("A" & 元ブック行数1 - 1) Then
wwww = Workbooks(元ブック名).Sheets(1).Range("A" & 元ブック行数1 - 1)
Workbooks(新ブック名).SaveAs "E:\" & wwww & ".xls"
ActiveWorkbook.Close
Workbooks.Add
wwww = Workbooks(元ブック名).Sheets(1).Range("A" & 元ブック行数1)
新ブック行数1 = 1
新ブック名 = ActiveWorkbook.Name
元ブック最終行2 = Workbooks(元ブック名).Sheets(2).Range("A65536").End(xlUp).Row
新ブック行数2 = 1

For 元ブック行数2 = 1 To 元ブック最終行2
If wwww = Workbooks(元ブック名).Sheets(2).Range("A" & 元ブック行数2) Then
Workbooks(元ブック名).Sheets(2).Range _
("A" & 元ブック行数2 & ":Z" & 元ブック行数2).Copy
Workbooks(新ブック名).Worksheets(2).Activate
Range("A" & 新ブック行数2).Select
ActiveSheet.Paste
新ブック行数2 = 新ブック行数2 + 1
End If
Next 元ブック行数2

End If
Workbooks(元ブック名).Sheets(1).Range _
("A" & 元ブック行数1 & ":Z" & 元ブック行数1).Copy
Workbooks(新ブック名).Worksheets(1).Activate
Range("A" & 新ブック行数1).Select
ActiveSheet.Paste
新ブック行数1 = 新ブック行数1 + 1
Next 元ブック行数1

wwww = Workbooks(元ブック名).Sheets(1).Range("A" & 元ブック最終行1)
Workbooks(新ブック名).SaveAs "E:\" & wwww & ".xls"
ActiveWorkbook.Close
End Sub

大まかな、処理の流れ
まず、一件目のデータで、1ブックを作ります。
それから、2件づつのデータを比べて、国が違ったら、の処理をしています。
最後にデータを書き出しています。

データは一行目から入っているものとして処理しています。
新しいブックの名前は、国名になっています。また、"E"ドライブに書き出していますので、適当に変えてください。
また、新しいブックには、A1:Z1迄、コピーしています。

お礼

ありがとうございました。
完璧に作動しました。

下でしたDoEventsの回答を見てからポイントを付けさせていただきます。
ほんとうにありがとう御座いました。

回答No.5

maruru01

＞DoEvnets でエラーになってしまいました。
すみません。綴りを間違えてました。
正しくは、

DoEvents

です。

お礼

ありがとうございました。
動きました。

回答No.3

maruru01

一応、A列の最終行が不定で、データの有無で判断するとして、Doループを使用します。

i = 1
StartRow = 1

Do
　　DoEvnets
　　If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
　　　　EndRow = i
　　　　'ここに新規ファイル作成、コピー・ペースト処理
　　　　StartRow = i + 1
　　End If
　　i = i + 1
Loop Until (Cells(i, 1).Value = "")

ループを使う場合は、RangeよりもCellsプロパティの方が見やすいと思います。
詳細はヘルプで。

補足

ありがとうございます。一応こんな形でやってみましたが、DoEvnets でエラーになってしまいました。

Sub BUNKATSU()

Dim StartRow As Integer
Dim EndRow As Integer
Dim 新ファイル名 As String

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

StartRow = 3

Do
DoEvnets

If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
EndRow = i

Range("A" & StartRow & ":D" & EndRow).Select

Selection.Copy
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste

Range("A1").Select
Application.CutCopyMode = False

新ファイル名 = Cells(1, 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

回答No.2

maruru01

こんにちは。maruru01です。

マクロ記録で範囲指定のコピーは、

Range("A1:C3").Select
Selection.Copy

となりますので、Rangeオブジェクトの中を変えればコピー出来るわけです。
やり方は、A列でソートした後で（ソートもマクロ記録でやってみて下さい。）、A列の値を順に見ていき（ForかDoループで）、内容が変わったところ（日本→韓国など）を終了行とします。（開始行は前の変わり目の次ですね。）
で、例えば、開始行をStartRow、終了行をEndRowなどの変数に格納して、

Range("A" & StartRow & ":D" & EndRow)

という風にすればA列の内容ごとにコピー出来ます。
そして、No.1の人の方法で、新規ブックを作成・保存し、そこへペーストします。

Workbooks(新規ブック名).Activate
WorkSheets(ペーストするシート名).Select
Range("A1").Select
ActiveSheet.Paste

という感じです。
あとは、新規ブックを保存して閉じます。
そしてまた、終了行の次からA列を見ていきます。
これの繰り返しで出来ると思います。

補足

ありがとうございます。

内容が変わったところ（日本→韓国など）を判別するのは多分

For i = 1 To (終了行までの行数)

If Range("A" & i + 1) <> Range("A" & i) Then だろうとは思うのですが、そのあとどんな記入になるのかお手上げです！すみません。

回答No.1

ta-nuki

アルゴリズムだけご提示しますと、

A列のデータ部分を国名でソートし、
A列の上下のセルの内容(国名)が異なっていれば
>Set newBook = Workbooks.Add
> With newBook
> .Title = "(A列のセルの内容を文字列化したもの(つまり国名))"
> .Subject = "お好きな名前"
> .SaveAs filename:="(A列のセルの内容を文字列化したもの)&.xls"
> End With
(ヘルプの丸写しです)として、新規にbookを作成して
データをそのブックに書きこんでゆけば良いとおもいます。

お礼

早速ありがとうございます。
元データは国名ですでにソートされているのです。
それをA列の上下のセルの内容(国名)が異なっていれば国別に分割（元データは残したまま）された６０いくつのブックを自動的に生成するというマクロが自分では書けないのです。トホホ。