「ブロック機能」のリニューアルについて

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

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

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

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

    No.1の回答に寄せられた補足コメントです。 補足日時:2016/12/02 08:02
教えて!goo グレード

A 回答 (2件)

No.1です。



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

というコトですので、↓の画像のように「リスト」シートに存在する顧客名のシートはすでに作成済みだという前提のコードにしました。
尚、画像のように「リスト」シートの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
「Excelで、リストから順番に値を取り出」の回答画像2
    • good
    • 0
この回答へのお礼

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

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

こんばんは!



各シートに表示するのは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
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング