Excelで、リストから順番に値を取り出して複数シートに入力する方法

Excel2010で教えて下さい
先頭シートに以下のような内容の“リスト”シートがあります。（A列に商品名。Ｂ列にお客様名。）
....A........B
1 商品a 田中
2 商品c 田中
3 商品a 鈴木
4 商品b 鈴木
5 商品c 佐藤
6 商品d 佐藤
このように、同一人物が2連続で表示。全ての人が2つずつ連続で並んでいます。
“リスト”シートの右に“案内文”シートがあります。
田中さんへの案内文のC1セルには商品a、C2セルには商品cと順番に入れて、お客様ごとのシートを右にどんどん追加するイメージで作成したいです。

今マクロできたのが
①リストの上から順番にお客様の名前のシートを作成する。お客様の名前１つ飛ばしでの作成がわからず、②全て作成した後、重複シートを削除する
という2種類のＶＢAを作りました。
ここまでできたのですが、
各シートに上から2こずつ順番に商品名を入れていくマクロの作り方がわかりません。
マクロでなくてもいいのですが、教えて頂けたらと思います。よろしくお願いいたします。

質問者からの補足コメント

• ご回答本当にありがとうございます。
  おっしゃる通り各シートに表示するのはA列のみです。（実際には製品番号で、重複してる番号はなく、あとは案内文にvlookで色々反映させるつもりです）
  それがすみません、やってみましたが、レベルが低く、できません(＞＜)
  実際には、
  お客様名は“リスト”シートのH列
  お客様名のついた各シートのＨ38、S38セルにそれぞれ製造番号を入れていきたいです。
  その場合回答頂いたVBAのどこを変えればよいでしょうか？
  教えて頂けたら幸いです。

  No.1の回答に寄せられた補足コメントです。 補足日時：2016/12/02 08:02

No.2 ベストアンサー 回答者： tom04 回答日時： 2016/12/02 19:13

No.1です。

前回は余計なお世話を焼いてしまったようですね。
＞今マクロできたのが
＞①リストの上から順番にお客様の名前のシートを作成する。お客様の名前１つ飛ばしでの作成がわからず、②全て作成した後、重複シートを削除する
という2種類のＶＢAを作りました。

というコトですので、↓の画像のように「リスト」シートに存在する顧客名のシートはすでに作成済みだという前提のコードにしました。
尚、画像のように「リスト」シートのH列（顧客名）は必ず連続していて、2行と決まっている！
という前提のコードです。
前回のコードは消去し↓のコードにしてみてください。

Sub Sample2()
Dim k As Long, c As Range, sN As String, wS As Worksheet
For k = 2 To Worksheets.Count
sN = Worksheets(k).Name
Set wS = Worksheets(sN)
With Worksheets("リスト")
Set c = .Range("H:H").Find(what:=sN, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then '←念のため//
wS.Range("H38") = .Cells(c.Row, "A")
wS.Range("S38") = .Cells(c.Row + 1, "A")
End If
End With
Next k
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

余計なお世話なんてとんでもないです！
そしてできました！
画像まで、ほんとにその通りです！
ありがとうございましたっほんとうに助かりました！！

お礼日時：2016/12/03 12:31

No.1 回答者： tom04 回答日時： 2016/11/30 20:15

こんばんは！

各シートに表示するのはA列だけでよいのですね？
一例です。
元データ（シート見出しの一番左側シート）は
1行目が項目行でデータは2行目以降にあるとします。
※　↑オートフィルタで処理するようにしていますので、項目行が必要です。※

尚、同一ブック内に同じシート名は付けられませんので
B列顧客名がなければシートを追加！あればそのシートに上書きする方法にしてみました。
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long
Dim sN As String, wS As Worksheet, myFlg As Boolean
Application.ScreenUpdating = False
With Worksheets(1)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("C:c").Insert '←作業用の列（C列）を挿入//
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("C1"), unique:=True
For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
sN = .Cells(i, "C")
For k = 2 To Worksheets.Count
If Worksheets(k).Name = sN Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sN
End If
Set wS = Worksheets(sN)
wS.Cells.Clear
With .Range("A1")
.AutoFilter field:=2, Criteria1:=sN
Range(.Cells(1, "A"), .Cells(lastRow, "A")).SpecialCells(xlCellTypeVisible).Copy wS.Range("A1")
End With
myFlg = False
Next i
.AutoFilterMode = False
.Range("C:C").Delete
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m