EXCEL VBA 社員毎にファイルを分割したい

質問

お世話になります。

実績.xlsというブックがあります。
これは社内の各支店の売上実績を個人別に記述したファイルです。
内容は下記のような感じです。
A列=支店名
B列=担当者名
C列=売上金額

このデータが記述しているシートの端にボタンをつけてクリックすると、B列の担当者別にファイルを分割して、データも担当者毎に分けて(A-C列をそのままコピーでいいです)デスクトップにファイルを保存する、ということは出来るのでしょうか？

ファイル名もA列+B列の支店名+担当者の名称で保存できれば最高です！
どなたかご教授いただけませんでしょうか？

添付図の例ですと６つのファイルが保存されることになります。

環境
Windows7
Excel2013

回答No.1

keithin · ベストアンサー

sub macro1()
　dim w as worksheet
　dim n as long
　dim r as long
　dim s as string
　dim WSH as variant
　dim myPath as string
　set w = activesheet
　n = worksheets.count

　on error goto errhandle
　for r = 2 to w.range("A65536").end(xlup).row
　　s = w.cells(r, "A") & "_" & w.cells(r, "B")
　　w.rows(r).copy worksheets(s).range("A65536").end(xlup).offset(1)
　next r
　on error goto 0

　set wsh = createobject("Wscript.Shell")
　mypath = wsh.specialfolders("Desktop") & "\"

　for r = worksheets.count to n + 1 step -1
　　worksheets(worksheets.count).copy
　　activesheet.columns.autofit
　　activeworkbook.saveas filename:=mypath & activesheet.name
　　activeworkbook.close false
　　application.displayalerts = false
　　worksheets(worksheets.count).delete
　　application.displayalerts = true
　next r
　w.select
　exit sub

errhandle:
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = s
　w.rows(1).copy range("A1")
　resume
end sub

お礼

keithinさん、ご連絡ありがとうございました！

ご連絡が遅くなりまして申し訳ございませんでした。

やりたいことが完璧に出来ました！！
本当にいつもいつもありがとうございます！！
今回も助かりました！