マクロでオートフィルタ？抽出し別シートへの転記がしたい

マクロ初心者です。仕事で膨大なデータ処理をする為にマクロを作りたいのでご教示ください。


リスト1　→　　リスト2
品名　　個別　　答え　　　　　品名　　　ａ１　a2　b1　b2
りんご　a1　　　　A　　　　りんご　　 A B C D
りんご　b1　　　　B　 みかん　　　　E F G H　　　
りんご　a2 C
りんご　b2 D
みかん　a1 E
みかん　b1 F
みかん　b2 G
みかん　a1 H

上記の様に別シートがあります。その中で品名を検索し個別にあるデータをリスト2へ転記したいです。品名は重複しているのでオートフィルタで抽出し別シートへの転記がわかりません。因みに個別はバラバラに並んでいます。

拙い文章で分かりづらく申し訳ありません。
宜しくお願いします。

No.1 回答者： tom04 回答日時： 2016/02/04 16:20

こんにちは！

「リスト1」の「みかん」に「a1」が重複していますが、
A列の同一品名にB列には重複データは存在しない！という前提です。

リスト1はSheet1にあり、Sheet2に表示するとします。
標準モジュールです。

Sub Sample1()
Dim i As Long, lastRow As Long
Dim c As Range, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("B1"), unique:=True
wS.Range("B:B").Sort key1:=wS.Range("B1"), order1:=xlAscending, Header:=xlYes
lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS.Cells(2, "B"), wS.Cells(lastRow, "B")).Copy
wS.Range("C1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
wS.Range("B:B").Delete
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Set r = wS.Rows(1).Find(what:=.Cells(i, "B"), LookIn:=xlValues, lookat:=xlWhole)
wS.Cells(c.Row, r.Column) = .Cells(i, "C")
Next i
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
wS.Activate
wS.Range("A1").Select
MsgBox "完了"
End Sub

※　お示しの「リスト1」の並びでは
「りんご」の行が　A・B・C・D　ではなく　A・C・B・D　になりますが
これで良かったのでしょうか？

じっくり考えればもっと簡単になるかもしれませんが、
こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ご回答ありがとうございました。先程　検証してみたのですが「wS.Range("C1").PasteSpecial Paste:=xlPasteAll, Transpose:=True」がデバックになってしまいました（泣）
こちらの言葉足りずにすみません。再度　検証してみます。

お礼日時：2016/02/04 18:05

No.2 回答者： tom04 回答日時： 2016/02/04 21:27

No.1です。

行列を入れ替えて貼り付けの部分でエラーになるのですね？
もしかしてシートモジュールにしていませんか？

もしそうであれば前回投稿したように標準モジュールで試してみてください。

もう一点気になるのがお使いのExcelのバージョンは何でしょうか？
2003までの場合、列数が256列までしか表示できませんので
Sheet1のB列データ数がそれを超える場合もエラーになるかもしれません。

現時点で考えられるのはこの程度ですかね。

※　他の原因ならごめんなさいね。m(_ _)m

この回答へのお礼

ご回答ありがとうございます。標準モジュールで貼り付けしましたがどうしても同じ箇所でデバックになってしまいました。エクセルは2013なので問題はないと思われます。
私の伝え方の問題ではないかと思います。もう一度検証してみます。ありがとうございました。

お礼日時：2016/02/05 11:14

No.3 ベストアンサー 回答者： tom04 回答日時： 2016/02/05 21:57

何度もおじゃまします。

Excel2013でやってみました。
ちゃんとSheet2に表示されましたので、コード自体は問題ないと思います。

もしかして前提条件（元データのレイアウト）が違うってコトはないでしょうか？
前回のコードは元データがSheet1のA～C列にあり、
1行目が項目行でデータは2行目以降にあるという前提のコードです。

この程度でごめんなさいね。m(_ _)m

この回答へのお礼

何度もご回答頂きありがとうございます。レイアウトが間違えていた為のデバックでした。上手くできました！大変助かりました。

お礼日時：2016/02/08 10:17

No.4 回答者： hallo-2007 回答日時： 2016/02/07 14:31

品名と個別の組み合わせで重複はないという事でよろしいでしょうか

リスト１は
　A　　　B　　　C
品名　　個別　　答え　
だとして

リスト２の
リンゴとa1のクロス部分に
=INDEX($C:$C,SUMPRODUCT(($A:$A=$D2)*($B:$B=E$1)*ROW(A:A)))
で右へコピー、下へコピーでは如何でしょうか。
SUMPRODUCT(($A:$A=$D2)*($B:$B=E$1)*ROW(A:A))
で、二つの条件があっている行の行番号が出ます。