全職員リストを営業所別シートへ変換する方法

お世話になります。
以前に個人名ごとにシートを分類したい方法をお伺いし、それは実現し活用しております。
その節はどうもありがとうございました。大変助かっております。

今回は別の条件(営業所ごと)で、シートを分類・シート名を付与する必要が出てきました。
現状、オートフィルタで営業所を絞り込み、1営業所ごとに該当する職員リストの印刷を実行するため印刷ミスや作業時間がかかってしまっており、それを削減するための方法を探しています。
※ピボットテーブルの使用を試みましたが、上記方法と大差はありませんでした

一覧となっているシート名「list]」のデータを基に、営業所ID(営業所名)別にシートを作成、営業所に所属している職員名とその等級をリスト化したいのですが、どのようにコードの記述を行えばよいのでしょうか。
シート名「list」は画像をご覧ください。

以下に用途、現状のシート、求めている結果を記述致しますので、お分かりの方はお教え頂けるととても助かります。

●シート名「list」の用途
1.シート名「list」を使用し、職員名、等級を、所定のWordファイルへ差し込み印刷、書類を作成
※変更を行えない所定のWordファイルです。
　2.印刷した書類の内容を確認・営業所別に仕分けする際に「○○(営業所名)」リストを作成・使用し、発送時に添付
　　※このリストの作成方法を探しています。

●現状のシート(添付画像、左側)
シート名　list
A列　グループID　(※原則1グループ)
B列　グループ名
C列　営業所ID　　(※平均50営業所)
D列　営業所名
E列　職員ID
F列　職員名
G列　等級(整数)
※各1行目には上記項目、2行目以降にデータが存在し、その最大件数は3,000程度です。
　データの内容(営業所の異動や氏名等)の変更はあっても、列番号や項目名は変更されません
※営業所ID及び営業所名の並び順はA,C,B,F営業所…とランダムですが、画像の通り営業所ごとのかたまりとして値が入力されています
※職員ID及び職員名は規則性無くランダムに入力されています。
※処理を行う都度、データ件数はバラバラで1営業所が2件の場合もあれば100件の場合もあります。
※処理上、必要であればH列以降に列の追加は可能です。


●求めている「○○(営業所名)」リスト、結果(添付画像、右側)
シート名：○○(営業所名)
シートの内容：シート名「list」に入力されている、シート名と一致する営業所のリストを作成
※表示する順番は後のシート名「list」と同様の営業所ID/職員IDで表示を行いたい
※表示する項目はC列営業所IDからG列等級まで、A列B列の優先度は低いです。
※印刷を行う際、不要な行列は印刷せずデータがある範囲だけ(指定した印刷範囲だけ)印刷を行いたい


非常に分かりにくい記述になってしまいましたが、何卒宜しくお願い致します。

No.1 回答者： Deathscythe#1 回答日時： 2015/01/07 11:59

C列、若しくはD列優先で並び替えれば「営業所ごとに分類」できませんか?

で、C列を見ながら営業所毎のリストに落とし込めばいけるのではないかと・・・

この回答への補足

ご回答ありがとうございます。
このデータは並び替えを行ってしまうと先に使用した差し込み印刷結果の確認に影響があるので、並び替えをせずに済む方法を探しています。

補足日時：2015/01/08 10:34

No.2 回答者： tom04 回答日時： 2015/01/08 22:23

こんばんは！

VBAになりますが、一例です。

画像が小さくて詳細が判らないので
「list」SheetのC～G列のみをC列の「営業所ID」別のSheetに表示するようにしています。
「list」SheetはSheet見出しの一番左側にあるとします。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, lastRow As Long, str As String
Dim wS As Worksheet, myFlg As Boolean
With Worksheets("list")
Worksheets.Add before:=Worksheets("list")
Set wS = Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
.Range("C:C").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
wS.Range("A1") = .Name
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
str = wS.Cells(i, "A")
.Range("A1").AutoFilter field:=3, Criteria1:=wS.Cells(i, "A")
For k = 3 To Worksheets.Count
myFlg = False
If Worksheets(k).Name = wS.Cells(i, "A") Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(wS.Cells(i - 1, "A").Text)
ActiveSheet.Name = str
End If
Worksheets(str).Cells.Clear
Range(.Cells(1, "C"), .Cells(lastRow, "G")).SpecialCells(xlCellTypeVisible).Copy Worksheets(str).Range("A1")
Worksheets(str).Columns.AutoFit
Next i
.AutoFilterMode = False
Application.DisplayAlerts = False
Worksheets(1).Delete
Application.DisplayAlerts = True
.Activate
End With
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

※　営業所名のSheetがない場合は追加しています。
※　「list」Sheetの変更があるたびにマクロを実行する必要があります。
※　各Sheetに抽出するだけでやめています。

とりあえずはこの程度でどうでしょうか？m(_ _)m