EXELで重複しない抽出をするVBAについて

質問

B7:B299にあるデータとD7:D299にあるデータで重複しない抽出を試みようと下記を探してきました。

Sub filtunq()
Range("O7:O20").Select
Selection.ClearContents
Range("B7:B299").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("F9"), Unique:=True
Range("F9:F65536").Select
Selection.Sort Key1:=Range("F10"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlStroke
Cells(9, "F").Select
End Sub

ただ、これはB列のみの事でBとDの両方を満たす条件で抽出させる場合、
つまり
　　B　　D　　　　O
黒田　　赤子　　黒田　赤子　
黒田　　白子　　黒田　白子
黒田　　赤子　　赤田　黒子　　
黒田　　白子　　黄田　赤子
赤田　　黒子　　黒田　黄子
黄田　　赤子　　
黒田　　黄子
赤田　　黒子

としたいのですが、どのように書けばよろしいでしょうか？
別に上記の式にこだわりはありませんのでもっと簡単になれば
その方がよいのですが・・・。
宜しくお願いします。

回答No.8

jcctaira · ベストアンサー

kyon0512さん
おはようございます。

データは以下の内容でプログラムを作っています。　
a社 A品（神）
b社 A品（神）
d社 A品（神）
g社 A品（神）
ab社 A品（東）
e社 A品（東）
da社 A品（東）
bd社 B品（大）
h社 B品（大）
ig社 B品（大）
as社 社内
bl社 メーカー
ccc社 メーカー
aj社 学生
br社 その他

※その他（社内、メーカー、学生、その他）は45行以降に順に表示しています。
　他に、何の文字が出現するかわからないので同一文字でまとめていません。
　必要なら自分で並べ替えしてください。

Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A品_神　As Long
　Dim A品_東　As Long
　Dim B品_大　As Long
　Dim その他 As Long
　Dim r　　　 As Long
　Dim 本支店　As Variant
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　A品_神 = 7
　　A品_東 = 27
　　B品_大 = 37
　　その他 = 45
　　For Each Key In .keys
　　　本支店 = Split(Key, "::")(1)
　　　Select Case 本支店
　　　　Case "A品（神）"
　　　　　Cells(A品_神, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_神, "P") = 本支店
　　　　　A品_神 = A品_神 + 1
　　　　Case "A品（東）"
　　　　　Cells(A品_東, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_東, "P") = 本支店
　　　　　A品_東 = A品_東 + 1
　　　　Case "B品（大）"
　　　　　Cells(B品_大, "O") = Split(Key, "::")(0)
　　　　　Cells(B品_大, "P") = 本支店
　　　　　B品_大 = B品_大 + 1
　　　　Case Else
　　　　　Cells(その他, "O") = Split(Key, "::")(0)
　　　　　Cells(その他, "P") = 本支店
　　　　　その他 = その他 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

お礼

おはようございます。
出来ました。
大変お世話になり、ありがとうございました。

回答No.7

jcctaira

kyon0512さん
おつかれさまです。

同じことを繰り返しているような感じです。
最終的にはどうしたいのでしょうか？

前回は　A品（神）、A品（東）…にしたのではなかったのですか？
プログラムのコードで使った変数と表のデータは全く別のものですよ。
よって、kyon0512さんはプログラムは考えないで、どういう表の内容をどうしたいのですか？

・以下のデータのように、（　）は使わないでA品_神、A品_東、B品_大で区別するのですか？
・社内、メーカーとか追加して表示したいのですか？
・その場合、何行目に表示したいのですか？

・次の説明が理解できません。
　1行目と２行目は同じと思うですが？
> A品_神 = 7　　A品_東 = 27　　B品_大 = 37を指定でなく
> 上から順にした方がいいみたいなのでA品_神 = 7　 A品_東= 27　B品_大 = 37

> jcctairaさんがVBAのHPも作られたら分かりやすいのを作られると思いますが。
　VBAを分かりやすく説明しようとすると、分厚い参考書のようになってしまう量です。
　そう簡単にはできないですね。

ちょっと言わさせて頂くと、
私はSEをやっていましたが、仕様がコロコロ変わるユーザは嫌われます。
最初から何を（元データ）をどうしたい…をはっきり決めてから、システム化要望することです。
kyon0512さんも分かるかと思いますが、プログラムを作って・テストをして完成したと思ったら
また安易に修正要望があって、最後だと思ってプログラムを完成したら、また修正要望…。
なるべく最終の仕様（プログラム作成要望）を確定するように心掛けてくださいね。

A品_神 = 7　、　A品_東 = 27　、　B品_大 = 37　、その他は　＝　？？？

a社　 A品_神
b社　 A品_神
d社　 A品_神
g社　 A品_神
ab社　A品_東
e社　 A品_東
da社　A品_東
bd社　B品_大
h社　 B品_大
ig社　B品_大

as社　社内
bl社　メーカー
ccc社　メーカー
aj社　学生
br社　その他

補足

おはようございます。
おっしゃるとおり、大変大変申し訳ありません。

・以下のデータのように、（　）は使わないでA品_神、A品_東、B品_大で区別するのですか？
　誤記です、最初のA品（神）、A品（東）…の表示のままです。
・社内、メーカーとか追加して表示したいのですか？
　最初本支店とかの例を出しましたが書いて頂いたモジュで本支店が残っていたのでそれはクリアーにし　て頂いて、社内とかメーカー・・に変更したいです。
・その場合、何行目に表示したいのですか？
　A品_神、A品_東、B品_大、社内、メーカー、学生、その他（以外のその他ということで）
　上記の７区分での上から順番に抽出です。

1行目と２行目は同じと思うですが？
> A品_神 = 7　　A品_東 = 27　　B品_大 = 37を指定でなく
> 上から順にした方がいいみたいなのでA品_神 = 7　 A品_東= 27　B品_大 = 37
すみません、誤記です。A品（神） = 7からから始まり、その次の行から行指定無しで続けてA品（東）、B品（大）、で社内=45行目から、順番に行指定無しで、メーカー、学生、その他
としたいです。

ころころ変わり本当に申し訳ありません。自分でも作りながら同じページに抽出するとなると
行幅も元のシートに合わせるとなると見にくい表になってしまし、どうしようかと色々と迷いながらやっているので
そうなってしまっています。
本当に済みません。
宜しくお願いします。

回答No.6

jcctaira

kyon0512さん
おはようございます。

すみません、プログラムが（　）が半角、全角と整理できていなかったので再度プログラムを掲載します。
訂正し、ご確認ください。
【確認】次の３種類で分けています。
　"A品（神）"
　"A品（東）"
　"B品（大）"

Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A品_神　As Long
　Dim A品_東　As Long
　Dim B品_大　As Long
　Dim r　　　 As Long
　Dim 本支店　As Variant
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　A品_神 = 7
　　A品_東 = 27
　　B品_大 = 37
　　For Each Key In .keys
　　　本支店 = Split(Key, "::")(1)
　　　Select Case 本支店
　　　　Case "A品（神）"
　　　　　Cells(A品_神, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_神, "P") = 本支店
　　　　　A品_神 = A品_神 + 1
　　　　Case "A品（東）"
　　　　　Cells(A品_東, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_東, "P") = 本支店
　　　　　A品_東 = A品_東 + 1
　　　　Case "B品（大）"
　　　　　Cells(B品_大, "O") = Split(Key, "::")(0)
　　　　　Cells(B品_大, "P") = 本支店
　　　　　B品_大 = B品_大 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

補足

出来ました、すごくすごく嬉しいです。
しかし、色々テストしている内に使い勝手が悪くもう少しご教授下さい。
１．A品_神 = 7　　A品_東 = 27　　B品_大 = 37を指定でなく
上から順にした方がいいみたいなのでA品_神 = 7　 A品_東= 27　B品_大 = 37
だけをはずしたりしてみますが、上手くいきません。

a社　 A品_神
b社　 A品_神
d社　 A品_神
g社　 A品_神
ab社　A品_東
e社　 A品_東
da社　A品_東
bd社　B品_大
h社　 B品_大
ig社　B品_大としたいのと

２．せっかく本支店とされてますので実際には社内、メーカー、学生、その他としているので
そのように変えてやってみるのですが、表示しません。
上記１．に続いて
as社　社内
bl社　メーカー
ccc社　メーカー
aj社　学生
br社　その他というふうになりませんでしょうか？

それからプロフィール拝見しましたらすごい方ですね。
こんな方に教えて頂いてたなんて、恐縮します。
VBAの勉強はいろんなHPで見てやってますが、なかなかわかりやすいのってないんですよね。
jcctairaさんがVBAのHPも作られたら分かりやすいのを作られると思いますが。

以上、済みませんがよろしくお願いします。

回答No.5

jcctaira

kyon0512さん

失礼と存じますが VBA はどこまでご存知でしょうか？
特に「変数」とか分かりますか？

> Dim A品（神）の神とところでコンパイルエラー定数式が必要です。
　変数に（　）を使用すると配列変数となります。
　当然（神）　は配列数が 神 と指定したため、数字ではないのでエラーとなります。

> Dim　r　は何なんでしょうか？
　変数として使用しています。
　For r = 7 To 299　→　7行目～299行目を調べるために使用しています。

申し訳ありませんが、もう少しマクロ（VBA)の基本を覚えないと、プログラムの修正（応用）は
難しいと思います。
勉強は大変だと思いますが、今後のためにしっかり覚えると後々楽になりますよ。

以下、要望に対応して作りました。
ただ、A品（神）　で「A」や「( )」が半角か全角か不明なので、確認して違っていたら変更してください。

Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A品_神　As Long
　Dim A品_東　As Long
　Dim B品_大　As Long
　Dim r　　　 As Long
　Dim 本支店　As Variant
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　A品_神 = 7
　　A品_東 = 27
　　B品_大 = 37
　　For Each Key In .keys
　　　本支店 = Split(Key, "::")(1)
　　　Select Case 本支店
　　　　Case "A品（神）"
　　　　　Cells(A品_神, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_神, "P") = 本支店
　　　　　A品_神 = A品_神 + 1
　　　　Case "A品（東)"
　　　　　Cells(A品_東, "O") = Split(Key, "::")(0)
　　　　　Cells(A品_東, "P") = 本支店
　　　　　A品_東 = A品_東 + 1
　　　　Case "B品_(大)"
　　　　　Cells(B品_大, "O") = Split(Key, "::")(0)
　　　　　Cells(B品_大, "P") = 本支店
　　　　　B品_大 = B品_大 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

補足

申し訳ありません、おっしゃるとおり、まだ毎日勉強している超初心者です。
変数も何となくという程度しかわかっていませんが、何とかわかろうと一生懸命になっているのですが。

とりあえず、A品（神）だけは抽出できました。
しかし他のA品_東　B品_大が出来ないのです。

そこで、上のモジュで本支店をなくして　A品_神　A品_東　B品_大だけでの抽出を試みておりますが
うまくいかず、A品_神　A品_東　B品_大でと、O列とQ列への抽出で再度お願い出来ませんでしょうか？

宜しくお願いします。

回答No.4

jcctaira

kyon0512さん

ちょっと意味が理解できていないかも知れません。
１．前回は「○○支店(A)●●支店(B)」と(A),(B)で分けていましたが
　　今回は「Ａ品（神）Ａ品（東）B品（大）」A品、B品で分けるということでしょうか？
　　またサンプルではＡ品は全角のＡでB品は半角のBになっていますが、半角の統一で良いのでしょうか？

2.A品（神）　A社　A品　7行目～
　社内　　　 qqq　B品　27行目～
　学生　　　　rrr　社員　37行目～
　※20行ならrrrは47行目～　に思うのですが…

3.どうもカッコは青帯がかかるみたいですので
　すみません、こちらでは現象が出ません。
　かっこ以外に特殊な文字（改行とか）入っていませんか？
　（　）ダメなら【 】とか　B品（大）→B品ー大ー　とかで試してください、

できればkyon0512さんも色々修正して試してくださいね。

Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A　　　 As Long
　Dim B　　　 As Long
　Dim その他　As Long
　Dim r　　　 As Long
　Dim 本支店　As Variant
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　A = 7
　　B = 27
　　その他 = 37
　　For Each Key In .keys
　　　本支店 = Split(Key, "::")(1)
　　　Select Case True
　　　　Case InStr(本支店, "A品") >= 1
　　　　　Cells(A, "O") = Split(Key, "::")(0)
　　　　　Cells(A, "P") = 本支店
　　　　　A = A + 1
　　　　Case InStr(本支店, "B品") >= 1
　　　　　Cells(B, "O") = Split(Key, "::")(0)
　　　　　Cells(B, "P") = 本支店
　　　　　B = B + 1
　　　　Case Else
　　　　　Cells(その他, "O") = Split(Key, "::")(0)
　　　　　Cells(その他, "P") = 本支店
　　　　　その他 = その他 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

補足

大変お手数をお掛けしております。
済みません前々回の本支店はクリアーにしていただきまして
C列に会社名が色々、E列に区分としてA品（神）A品（東）B品（大）として
P列とR列にそれぞれ対応した抽出をしたいと思います。
Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A品（神）　　 As Long
　Dim A品（東）As Long
　Dim B品（大）　As Long
　Dim r　　　 As Long
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "C") & "::" & Cells(r, "E")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("P3:P299","R3:R299").ClearContents
　　A品（神） = 7
　　A品（東） = 27
　　B品（大） = 37
　　For Each Key In .keys
　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub
としましたらDim A品（神）の神とところでコンパイルエラー定数式が必要です。
と出ますので"神"としますと型が一致しませんとでます。

それからDim　r　は何なんでしょうか？
一応調べましたが・・・。

以上宜しくお願いします。

回答No.3

jcctaira

kyon0512さん
こんにちは

> xxx支店(A)とかカッコを付けているのですがカッコはエラーになりますね
　こちらでテスト(Win7,EXCEL2003)ではエラーになりません。
　動作、環境が違うのですかね？

> (A)に対するB列は20行もあれば足りますのでO7～O17
　これでは１１行ですよ。
　自分でプログラムを好きなように修正してくださいね。

> シートのイベントに書くとすると１２ヶ月ありますので全部書いてやらないといけないのですが
はい、そうです。

以下プログラムを修正しましたが、kyon0512さんの要望事項にあっているか分かりませんが…
ご確認ください。

Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim A　　　 As Long
　Dim B　　　 As Long
　Dim その他　As Long
　Dim r　　　 As Long
　Dim 本支店　As Variant
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　A = 7
　　B = 18
　　その他 = 29
　　For Each Key In .keys
　　　本支店 = Split(Key, "::")(1)
　　　Select Case True
　　　　Case InStr(本支店, "(A)") >= 1
　　　　　Cells(A, "O") = Split(Key, "::")(0)
　　　　　Cells(A, "P") = 本支店
　　　　　A = A + 1
　　　　Case InStr(本支店, "(B)") >= 1
　　　　　Cells(B, "O") = Split(Key, "::")(0)
　　　　　Cells(B, "P") = 本支店
　　　　　B = B + 1
　　　　Case Else
　　　　　Cells(その他, "O") = Split(Key, "::")(0)
　　　　　Cells(その他, "P") = 本支店
　　　　　その他 = その他 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

お礼

すみません、やはりＡ品（神）Ａ品（東）B品（大）と（）の中迄でないと具合が悪いみたいです。
多分、僕のやり方が悪かったと思います。XPでもWIN7でも大したかわりはないと思いますが。
宜しくお願いします。

補足

解答ありがとうございます。
どうも伝わらなくてすみませんです、上記に色々入れてやってみますがどうもうまくいきません。
こちらの環境は（XP　エクセル２００７）です。
どうもカッコは青帯がかかるみたいですのでA品としてひとまとめで結構です。
以下下記がやりたいことです。
何かややこしくなってしまいまして本当に申し訳ありません。

　C　　　E　　　　　P　　　Q
会社名　
A社とか　A品（神）　A社　A品　7行目～
B社　　　A品（東）　B社　A品　
　　　　　B品（大）　・　　　
　　　　　社員　　　 ・
　　　　　社内　　　 qqq　B品　27行目～
　　　　　メーカー　 ・
　　　　　学生　　　　rrr　社員　37行目～
　　　　　その他　　　ggg　社員
　　　　　　　　　　　ppp　社内
　　　　　　　　　　　lll　社内
　　　　　　　　　　fff　メーカー
　　　　　　　　　　vv　　メーカー
　　　　　　　　　　hhh　学生
　　　　　　　　　　kk　　その他

回答No.2

jcctaira

kyon0512さん
一応ご要望通り作成しましたが、要望の意図がちょっとつかめません。

1.入力データが「B7:B299にあるデータとD7:D299」となっていると思いますが
　出力はデータは「赤子はP3行目から白子はP10行目から黒子はP17行目」と３行目からになっています。
　先頭行を合わせなくて良いのですか？

2.入力データがB7:B299の293データありますが、出力は赤子・白子は7データ分しか無いので
　それ以上抽出した場合、上書きされてしまうと思いますが…

3.データの種類は赤子・白子・黒子の3種類で良いのでしょうか？
　それ以外のデータを入力した場合は抽出しないことになります。

4.「thisworkbookに書いて、データを入れたらいれたセルから次々と抽出するって…」
　下記のようにすればできますが、thisworkbookではなく、シートのイベントですね。
　ただ、入力した都度表示していたら、入力が多い場合表示する時に待ち時間を生じます。
　今回は「B7:B299、D7:D299」に入力したら抽出処理するようにしています。
　もしその表示が遅いようなら、違うイベント（例えばシートがActiveになった時）に
　抽出処理（ユニーク抽出）を実行すれば良いかと思います。
　kyon0512さんが色々試して、どのタイミングで抽出すれば良いか検討ください。

【入力シートのコードを記述】
Private Sub Worksheet_Change(ByVal Target As Range)
　If Intersect(Target, Range("B7:B299,D7:D299")) Is Nothing Then Exit Sub
　Call ユニーク抽出
End Sub

【標準モジュールにコードを記述】
Public Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim 赤子　　As Long
　Dim 白子　　As Long
　Dim 黒子　　As Long
　Dim r　　　 As Long
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象に抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "::" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果を出力
　　Range("O3:P299").ClearContents
　　赤子 = 3
　　白子 = 10
　　黒子 = 17
　　For Each Key In .keys
　　　Select Case Split(Key, "::")(1)
　　　　Case "赤子"
　　　　　Cells(赤子, "O") = Split(Key, "::")(0)
　　　　　Cells(赤子, "P") = Split(Key, "::")(1)
　　　　　赤子 = 赤子 + 1
　　　　Case "白子"
　　　　　Cells(白子, "O") = Split(Key, "::")(0)
　　　　　Cells(白子, "P") = Split(Key, "::")(1)
　　　　　白子 = 白子 + 1
　　　　Case "黒子"
　　　　　Cells(黒子, "O") = Split(Key, "::")(0)
　　　　　Cells(黒子, "P") = Split(Key, "::")(1)
　　　　　黒子 = 黒子 + 1
　　　End Select
　　Next
　End With
　Set Dict = Nothing
End Sub

お礼

ご丁寧な返信で大変ありがとうございます。
あーなるほどです、シートのイベントに書くと書いたり消したりした都度からできますね、本当素晴らしいです。ただ、おっしゃるとおり不備がありましたので下記をご検討下さいませんでしょうか？
１．D列のデータをP列に抽出ですがこれは支店別の抽出をしたいので先頭を合わせる必要はありません、ただxxx支店(A)とかカッコを付けているのですがカッコはエラーになりますね、これは何ともなりませんでしょうか？

２．例が悪くて、すみませんでした、下記のようにB列には色々な名前がはいります。
(A)に対するB列は20行もあれば足りますのでO7～O17とP7～P17
(B)はO18～O28とP18～P28、本店、支店、その他は連続でその順番で抽出です。
B　　　　D　　　　　O　　　P
ABC　　○○支店(A)　ABC　　○○支店(A)　　
BCD　　●●支店(B)　BCD　　●●支店(B)　
CDE　　本店　　　　CDE　　本店
DEF　　支店　　　　DEF　　支店
FRT　　その他　　　FRT　　その他

４．シートのイベントに書くとすると１２ヶ月ありますので全部書いてやらないといけないのですが？

何度もお手数をお掛けして申し訳ありません。
宜しくお願いします。

回答No.1

jcctaira

kyon0512さん
こんにちは。

フィルターとかを使用せず、VBAで単純に重複（同一キー）以外をメモリに貯めてから、O列に出力しています。

Sub ユニーク抽出()
　Dim Dict　　As Object
　Dim Key　　 As Variant
　Dim r　　　 As Long
　Set Dict = CreateObject("Scripting.Dictionary")
　With Dict
　　' 7行～299行を対象にメモリーに抽出
　　For r = 7 To 299
　　　Key = Cells(r, "B") & "　" & Cells(r, "D")
　　　If .Exists(Key) = False Then
　　　　.Add Key, ""
　　　End If
　　Next r
　　' 抽出結果をO7～　に出力
　　Range("O7:O299").ClearContents
　　r = 7
　　For Each Key In .keys
　　　Cells(r, "O") = Key
　　　r = r + 1
　　Next
　End With
　Set Dict = Nothing
End Sub

お試しください。

補足

早速の解答大変ありがとうございます。
すみません、ちょっと、急いで書いたものですから、大分やりたいことが説明不足でした。BとDのデータはO列に一緒に出したらいけなくてあくまでもBとDのつながりをO列とP列に抽出したいのです。
それから赤子はP3行目から白子はP10行目から黒子はP17行目から抽出したかったです。
それと罫線もOとPの抽出した処に引きたいです。
　　B　　D　　　　O　　P
黒田　　赤子　　黒田　赤子　
黒田　　白子　　黄田　赤子
黒田　　赤子　　　　　　
黒田　　白子　　黒田　白子
赤田　　黒子　　
黄田　　赤子　　赤田　黒子
黒田　　黄子　　
赤田　　黒子

それからもし出来るならイベントプロシージャでボタンに登録する方法でなくて、thisworkbookに書いて、データを入れたらいれたセルから次々と抽出するっていうやり方は出来ないのでしょうか？
例えば=SUM(A1:A10)としておけば入れると次々に計算してくれますが、そんな方法がthisworkbookに書いて出来ないものかと思いまして。
説明が不足しており、大変申し訳ありませんでした。
よろしくお願いします。