エクセルVBA：表の内容を担当者別に振り分けたい

質問

よろしくお願いいたします。
ＶＢＡ初心者です。よろしくご指導をお願いいたします。
安易に教えてgooで質問することにお叱りをいただくこともあり、
ＶＢＡの本も数冊買って勉強をはじめ、格闘していますが、手に負えません。どうか助けてください。

　　A　　　　　B　　　C　　　D　　　E　　　　F　　　ｇ
　担当者　　日付　商品　規格　数量　　単価　備考
1山田太郎　　○　　△　　■　　　◎　　◇　　　▼
2鈴木次郎　　■　　○　　▼　　　■　　○　　　○
3佐藤三郎　　△　　■　　○　　　◎　　◎　　　■
4山田太郎　　▼　　■　　◎　　　■　　○　　　▼
5山田太郎　　◇　　○　　◎　　　◇　　◆　　　◎
6鈴木次郎　　◆　　◎　　◇　　　◎　　◇　　　◇

というような入力シートの表があり、レコードは1000以上、下にたくさん続きます。
○や▼には実際には数値や商品名、短文などが入ります。

担当者は、50名、そこで「山田太郎」をはじめ、担当者氏名の名前の50のワークシートを作成しています。

そこで、次のようなVBAを書きたいのです。
ＶＢＡを実行すると、

シート別に入力表のデータが振り分けられて、
「山田太郎」に
　A　　B　　　C　　　D　　　E　　　　F　　　ｇ
1　　日付　商品　規格　数量　　単価　　備考
2　　○　　△　　■　　　◎　　◇　　　　▼
3　　▼　　■　　◎　　　■　　○　　　　▼
4　　◇　　○　　◎　　　◇　　◆　　　　◎
と入力シートに入力されたデータが50名のシートに振り分けられるものです。
どうか、よろしくご指導お願いいたします。

回答No.3

ham_kamo · ベストアンサー

No.2です。大変失礼しました。十分な確認ができてないまま投稿してしまいました。

TmpWS.Columns("A:A").Sort Key1:=Range("A2"), Header:=xlYes
の行を
TmpWS.Columns("A:G").Sort Key1:=Range("A2"), Header:=xlYes
に変更してください。やり直すときは、作成された担当者別のシートは削除してからでお願いします。

お礼

ありがとうございました。
完璧にできました^^
心より感謝申し上げます。
初心者ながら、なぜ、最初のコードではできなかったかも理解できました。並び替えがデータ全体に及んでなかっただけですね。
本当に、本当にありがとうございました。
こんなに素敵なコードが書けるように私も勉強していきたいです。

回答No.2

ham_kamo

マクロを書いてみました。
一度シートを作業用にコピーし、担当者別にソートしてから他のシートに振り分け、最後に作業用シートを削除しています。
「挿入」＞「標準モジュール」を選択して、以下のマクロを貼り付けて実行してください。
マクロ中の"Sheet1"という部分は、実際に元データが入っているシート名に変更してください。

Sub 担当者別に振り分け()
　　Dim OrgWS As Worksheet, TmpWS As Worksheet, CurWS As Worksheet
　　Dim FromCell As Range
　　Dim ToCellNum As Integer
　　Dim CurName As String

　　'変数初期化
　　Set OrgWS = Worksheets("Sheet1") '元のデータがあるシート名を指定
　　CurName = ""

　　'処理終了まで描画を止める
　　Application.ScreenUpdating = False

　　'シートを作業用にコピーして担当者でソート
　　OrgWS.Copy after:=Sheets(Worksheets.Count)
　　Set TmpWS = Worksheets(Worksheets.Count)
　　TmpWS.Columns("A:A").Sort Key1:=Range("A2"), Header:=xlYes

　　'メイン処理
　　For Each FromCell In TmpWS.Range("A2", TmpWS.Range("A65536").End(xlUp))
　　　　If FromCell.Value <> CurName Then '次の担当者に移った場合
　　　　　　CurName = FromCell.Value
　　　　　　Worksheets.Add after:=Worksheets(Worksheets.Count) 'シートを最後に追加
　　　　　　Set CurWS = Worksheets(Worksheets.Count)
　　　　　　CurWS.Name = CurName 'シート名を担当者にする
　　　　　　ToCellNum = 2 'コピー先セルの行番号を初期設定
　　　　　　OrgWS.Range("B1", "G1").Copy CurWS.Range("A1") 'タイトル行をコピー
　　　　End If
　　　　FromCell.Offset(0, 1).Resize(1, 6).Copy CurWS.Cells(ToCellNum, 1) 'データのコピー
　　　　ToCellNum = ToCellNum + 1 'コピー先セルを一つ下に進める
　　Next

　　'作業用シートを削除
　　Application.DisplayAlerts = False
　　TmpWS.Delete
　　Application.DisplayAlerts = True

　　'描画を再開
　　Application.ScreenUpdating = True

End Sub

補足

早速のご回答ありがとうございます。
やはり、私の手におえないものでした。
まずは、コードを感謝いたします。

まず、担当者シートは瞬時にできました。感謝です。
ところが、振り分けが担当者別に正しくなされませんでした。
どこで不具合を起こしているのか、わかりません。
どうか、続けてのご指導をお願いいたします。

回答No.1

cafe_au_lait

コードの流れは参考URLのNo.1さんの回答が参考になると思います。
まだ自力では・・・というようでしたら補足してください。

参考URL：

http://oshiete1.goo.ne.jp/qa2662756.html

お礼

ありがとうございました。NO．２さんで完全解決いたしました。
もし、コードなど書いていただいていた途中なら申し訳ありません。
ただ、アドバイスくださいましたことを、心より感謝いたします。
ありがとうございました。

補足

アドバイスをありがとうございます。
なるほど、そっくりの質問、ご回答があったのですね。

No.1さんのコードの流れの解説は概ね理解できました。
ところが、私のスキルがマクロを自動記録させて修正、応用する程度なので、やはり新規コードを書くことは困難ですし、本を開いても、まださっぱりです。

もし、可能なら続けてご指導いただけますでしょうか？
ただ、Ｎｏ．２さんと並行してご指導依頼をしていますことをお許しくださいませ。