VBA 条件一致 抽出 ループ

質問

《シート１》(仮)
　 A 　　B　　C　　
1　赤　　1　トマト　
2　赤　　2　いちご
3　赤　　3　りんご
4　青　　1　ぞう
5　青　　2　そら
6　青　　3　みず
7　黄　　1　ひよこ
8　黄　　2　ひまわり
9　緑　　1　かえる
10 緑　　2　葉
11 緑　　3　高原
・
・
・

《シート２》(マクロ実行後の結果)
　 A 　　B　　　C　　　D　　　
1　赤　トマト　いちご　りんご　
2　青　ぞう　　そら　　みず
3　黄　ひよこ　ひまわり
4　緑　かえる　葉　　　高原

★依頼★《シート１》から《シート２》のような表を作りたい。

《シート１》のような表がある場合、
《シート１》のＢ列の値が１ならば
　　《シート２》のＡ列とＢ列にそれぞれ《シート１》のＡ列とＣ列を
《シート１》のＢ列の値が２ならば
　　《シート２》のＣ列に《シート１》のＣ列を、
《シート１》のＢ列の値が３ならば
　　《シート２》のＤ列に《シート１》のＣ列を抽出したい。

またこの際《シート１》は(仮)のシートであり、実際はＢ列の数字は１からいくつまであるかわからない。数字かある限りこの処理を繰り返し行いたい。
《シート１》Ｂ列１値がについては《シート２》のＡ列とＢ列に《シート１》のＡ列とＣ列を抽出するのはかわらないが、《シート１》のＢ列の値が２以上のものについては《シート２》のＣ列以降に横に抽出していきたい。
さらに《シート１》のＡ列の”黄“の項目のみＢ列の値は２までしかない。
このような時、
次の項目”緑“の３の値が”黄“の項目の３に重ならないようにしたい。
このような場合、マクロをどのように組んだら良いでしょうか。
ＶＢＡのテキストを読んでみましたがなかなかできません。
説明が下手ですみませんがどなたか回答頂けたら幸いです。

回答No.1

keithin · ベストアンサー

ご相談で書かれている通りに、１行目にタイトル行など用意してない、１行目からいきなり生データが記入してあるとします
１行ずつループしてひとつずつ調べてくみたいな遅い事はしないでみます。

sub macro1()
’整形
　worksheets("Sheet1").select
　worksheets("Sheet2").cells.clearcontents
　range("1:1").insert shift:=xlshiftdown
　range("A1:C1") = array("F1","F2","F3")
　range("C:C").insert
　range("C2:C" & range("D65536").end(xlup).row).formula = "=A2&""_""&B2"

’項目の抽出
　range("B1:B" & range("B65536").end(xlup).row).advancedfilter _
　　action:=xlfiltercopy, _
　　copytorange:=worksheets("Sheet2").range("A1"), _
　　unique:=true

’横向け
　worksheets("Sheet2").range("A2:A" & range("A1").end(xldown).row).copy
　worksheets("Sheet2").range("B1").pastespecial transpose:=true
　worksheets("Sheet2").range("A:A").clearcontents

’項目の抽出
　range("A1:A" & range("A65536").end(xlup).row).advancedfilter _
　　action:=xlfiltercopy, _
　　copytorange:=worksheets("Sheet2").range("A1"), _
　　unique:=true

’データの抽出
　with worksheets("Sheet2").range("A1").currentregion.offset(1,1)
　　.formula = "=VLOOKUP($A2&""_""&B$1,Sheet1!$C:$D,2,FALSE)
　　.value = .value
　　.specialcells(xlcelltypeconstants, xlerrors).clearcontents
　end with

’後片付け
　worksheets("Sheet2").range("A1").clearcontents
　range("C:C").delete shift:=xlshifttoleft
　range("1:1").delete shift:=xlshiftup
　worksheets("Sheet2").select
end sub

お礼

お早い回答有り難うございます。
なんだか、ボケている質問だったらすみません。
データ抽出のところで、withを使用していますが、そちらう後ろには何を記載したら良いでしょうか。
また、こちらを実行すると同じところ(データ抽出)のworksheetsの部分でオブジェクトは、このプロパティまたはメソッドをサポートしていません。と出てしまいます。
もし私のモジュールへの書き方がおかしかったらすみませんが、
ご指示いただけないでしょうか。

補足

補足より失礼致します。
私の書き方がおかしかったようです。
またこちらの使い方も慣れていなく、
お礼を書き直したり等できなそうなので、
こちらに書かせて頂きます。
お早い回答有り難うございました。