ExcelVBA支店名の付いたブックの複数作製

質問

お世話になります。

添付のような各支店のパンの売上数量をまとめたデータがあります。

やりたいこと・・・
今回の例では東京支店、名古屋支店、大阪支店が１つのブックにまとまっていますが、これを支店別のブックに分けたいのです。
データの構造や保存場所は変わらず、支店別のブックを作製したいのです。

さらに要約しますと・・
添付のブックをもとに、A列の支店名から東京支店.xls 名古屋支店.xls 大阪支店.xlsという３つのブックに分解するイメージです。ブック名はA列から持ってこれるようにしたいです。
ちなみにA列の支店名は支店毎に一塊になっていて、とびとびに出現することはありません。

どなたかお力添えいただけませんでしょうか？
よろしくお願い致します。

環境
Windows XP SP3
Excel2003

回答No.2

keithin · ベストアンサー

sub macro1()
　dim buf as variant

　activesheet.copy
　application.displayalerts = false

　do until range("A2") = ""
　　buf = range("A2")
　　activesheet.copy

　　range("A:A").autofilter field:=1, criteria1:="<>" & buf
　　activesheet.autofilter.range.offset(1).entirerow.delete shift:=xlshiftup
　　activesheet.autofiltermode = false
　　activeworkbook.saveas buf & ".xls"
　　activeworkbook.close false

　　range("A:A").autofilter field:=1, criteria1:=buf
　　activesheet.autofilter.range.offset(1).entirerow.delete shift:=xlshiftup
　　activesheet.autofiltermode = false
　loop
　activeworkbook.close false
end sub

sub macro2()
　dim h as range
　dim i as long, n as long

　on error goto errhandle
　for each h in range("A2:A" & range("A65536").end(xlup).row)
　　h.entirerow.copy worksheets(h.value).range("A65536").end(xlup).offset(1)
　next

　application.displayalerts = false
　for i = 1 to n
　　worksheets(1).move
　　activeworkbook.saveas range("A2").value & ".xls"
　　activeworkbook.close false
　next i
　exit sub

errhandle:
　worksheets.add before:=worksheets(1)
　h.parent.range("1:1").copy range("A1")
　n = n + 1
　activesheet.name = h.value
　resume
end sub

お礼

keithinさん、早速のご連絡ありがとうございます！

出来ました！！
遅い時間にどうもありがとうございました。
ロジックも2つご教授いただきましてありがとうございます！

お陰様で朝一から活用させていただくことができました。
この度は本当にありがとうございました m(_ _ )m

回答No.1

bin-chan

> 今回の例では東京支店、名古屋支店、大阪支店が１つのブックにまとまっていますが
１ブックかつ１シートと理解して良いですか？

ブックを３つにコピーして、対象とする支店のデータを残し他支店データを消去
するのが簡単では？

お礼

bin-chanさん、早速のご連絡ありがとうございました。

私の説明不足で貴重なお時間をいただいてしまいまして、大変申し訳ございませんでした。

この度はありがとうございました m(_ _ )m

補足

スイマセン、肝心な事を書いていませんでした。本件はボタンを作成して、ボタンがクリックされたときに、投稿した内容の処理ができるロジックを教えていただきたかったのです。申し訳ありませんでした。