マクロ初心者です。エクセルで複数条件でデータの抽出をしたいのですがうまくできません。どなたか教えてください。

マクロ初心者です。エクセルで複数条件でデータの抽出をしたいのですがうまくできません。どなたか教えてください。 データはこんな感じです。 A列 B列 C列 D列 E列 F列 G列 1 商品名 売上日 曜日 部署 担当者 支店 本店 2 本 3/1 木 総務 Aさん ○ 3 つくえ 3/2 金 営業 Bさん ○ 4 本 3/5 月 総務 Cさん ○ 5 ペン 3/6 火 総務 Dさん ○ 6 本 3/6 火 総務 Dさん ○ 7 紙 3/6 火 総務 Dさん ○ 8 つくえ 3/7 水 営業 Eさん ○ とこんな感じでデータがあります A列とF列とG列のデータで重複することなく項目を同じシートのI列からに抽出していきたいです。 イメージはこんな感じです。 I列 J列 K列 1 商品名 支店 本店 2 本 ○ 3 つくえ ○ 4 本 ○ 5 ペン ○ 6 紙 ○ ちなみにL列にはCOUNTA関数が入っています。(=COUNTIFS(A1:G200,I2)) Sub マクロ1() Worksheets("Sheet1").Range("I:K").Clear With Worksheets("sheet1") .Range("A1:G4").Copy Worksheets("Sheet1").Range("I1") .Range("A1:A500").AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("I1:K2"), _ CopyToRange:=.Range("I2"), _ Unique:=True End With End Sub 上記のマクロで実行すると、表がすべて抽出されてしまいます。 説明がうまくできなくてすみません。 どなたかお分かりになる方アドバイスをいただけないでしょうか???

補足

入力がうまくできていませんでした。 本店 支店の下には該当のところにどちらか ○ が入力されています。

iOS開発1,822閲覧xmlns="http://www.w3.org/2000/svg">250

ベストアンサー

0

Dictionaryオブジェクトを用いた一例ですが。 Sub try() Dim myDic As Object Dim r As Range Dim st As String Set myDic = CreateObject("Scripting.Dictionary") With Worksheets("Sheet1") .Range("I:K").Clear For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp)) st = r.Value & "_" & r.Offset(, 5).Value & "_" & r.Offset(, 6).Value If Not myDic.Exists(st) Then myDic(st) = Array(r.Value, r.Offset(, 5).Value, r.Offset(, 6).Value) Next .Range("I1:K1").Value = Array("商品名", "支店", "本店") .Range("I2").Resize(myDic.Count, 3).Value = Application.Transpose(Application.Transpose(myDic.Items)) End With Set myDic = Nothing End Sub ご参考になれば。

ThanksImg質問者からのお礼コメント

早速のアドバイスありがとうございました。 お二人の方にご回答していただきましたが、私のイメージしていたものが帰って来た方がこちらでしたので選ばせていただきました。ありがとうございました。 ちなみに月が変わってシートを別にしたいときは”sheet1”の部分を毎回書き換えていくしかないのでしょうか?もしお分かりになりましたらお教えください。

お礼日時:2012/3/15 10:31

その他の回答(1件)

0

対象がA列・F列・G列と離れた範囲の場合でアドバンスフィルタを使用する場合は、合計2回アドバンスフィルタを使用しなければならないかもしれません。内容を完全に把握したわけではありませんが、下記VBAのようなアドバンスフィルタを参考下さい。 ************************************************************ Sub Sample() Dim val, i As Long Range("I:K").Delete Range("A1:G" & Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter 2, , Range("P1"), 1 Range("Q:T").Delete Range("P1:R8").AdvancedFilter 2, , Range("I1"), 1 Range("P:R").Delete End Sub ************************************************************