vbaマクロ一覧から担当者別にデータを転機する方法

質問

vbaマクロ初心者です。
次のような処理をしたいのですが、調べてもなかなか思うようにいかず
ここに辿りつきました。良い方法を教えてください。

【マクロで行いたい処理】
「一覧（*）のデータを、担当者毎に分かれた別シートにデータを転記する処理」

・一覧シート上にある下記のようなデータを「担当者」にフィルターをかけて、
別の担当者毎作成したシートにデータを転記したい。
（例　「山田」シートに「一覧」シートの山田さんの行のデータをコピーしてもってくる）

・すでに担当者毎のシートは作成されているものとします。
・「一覧」シートに複数回分かれて同一人物名前がでてきます。（例山田さんが８行目、１８行目に出てくる）
・「一覧」シートのデータは１００～２００行、担当者は１０名ほどです。

「一覧」シート（*）
　担当者　　商品　　売・買　　実施日　
　山田　　　りんご　　売　　　　2/11
　鈴木 みかん　　買　　　　2/25
　田中 いちご　　　買
　山田　　　いちご　　売
　山田　　　オレンジ　買

また、一覧シートに記載されているが、個別の担当者シートがない場合に
メッセージ等で知らせてくれる処理がありましたらその機能も追加したいと思っております。
（上記の例で申しますと、田中さんシートが処理前に作成されていないケースでそれをマクロ処理中に教えてくれる）

文章に落とすとわかりづらくなってしまい、申し訳ないのですが、どうぞよろしくお願い致します。

回答No.1

jin34 · ベストアンサー

一覧シートのA列の各セルの値（担当者）について、
全シートのシート名と照合し、見つかればそのシートの最終行に行データを追加、
見つからなければシート追加し、２行目に追加するという流れです。
あらかじめ各担当者シートの１行目に
「一覧」シートの列見出し（１行目）をコピー＆ペーストしておいてください。

Sub test()

Dim i As Integer
Dim j As Integer
Dim mysht As Worksheet

i = 2
Do Until Sheets("一覧").Range("A" & i) = ""
For Each mysht In ThisWorkbook.Worksheets
If mysht.Name = Worksheets("一覧").Range("A" & i).Value Then
j = mysht.Range("A65536").End(xlUp).Row + 1
Worksheets("一覧").Rows(i).Copy mysht.Range("A" & j)
Exit For
End If
If mysht.Index = ThisWorkbook.Worksheets.Count Then
MsgBox "シート「" & Worksheets("一覧").Range("A" & i).Value & "」が見つかりません。" & vbCrLf & _
"シートを追加します。"
Worksheets.Add after:=Worksheets(ThisWorkbook.Worksheets.Count)
With Worksheets("一覧")
ActiveSheet.Name = .Range("A" & i).Value
.Rows(1).Copy ActiveSheet.Range("A1")
.Rows(i).Copy ActiveSheet.Range("A2")
.Activate
End With
End If

Next

i = i + 1
Loop
MsgBox "終了しました。"
End Sub

お礼

早速ご回答有難うございました!!
コピペしたところ大成功でした。
有難うございました。

日次作業でしたので大変助かりました。
vbaを学ぶ近道はやはり事例をつんでコピペするのがよいのでしょうか？？
直に手入力するとなかなかうまくいかないのが実情です。。

回答No.2

MARU4812

>・「一覧」シートのデータは１００～２００行、担当者は１０名ほどです。
この規模ならオートフィルタを順に掛けて全選択コピペを手作業で繰り返しても
10分程度で終わってしまう。これが月に1回発生する業務だと仮定して、1年で
たった2時間の業務時間しか使わなかった場合、マクロの作成に(掲示板での
やり取りを含めて)2時間以上掛けたら費用対効果が劣るという罠。

・・・もう手作業でいいんじゃね？