Excel2007で複数のセルを併せて参照して

質問

Excel2007で複数のセルを併せて参照してデータを抽出したいんですがやり方がわかりません。ここから質問になります。
セルO4,P4,Q4から下に向かって各セルにア、イ、ウ、エ、オのいずれかが(今のところ)セルO50、P50、Q50までデータとして入ってます。マクロボタンを押すと一行ずつデータが追加されます。

B3からD5に格子を用意しました。B3:D5にデータO,P,Qの最下行から2行上までをまとめてコピペします。コピペされたそれらを併せて参照してデータO4:Q48(今のところO50:Q50が最下行なのと2行上までがコピー範囲なのでQ48としました)から探してその1つ下の3列データ(O?,P?,Q?)をG3、H3、I3、から下に向かって抽出したいです。
私的にはUnionメソッドを使ってするのかなぁと思ってます。
ご協力お願いします。

回答No.9

watabe007

>O:Qのどこから取り出されたか一見して分かりやすいようにするには色を着けたいと思っております。
Sub Test5()
　　Dim LastO As Long, LastG As Long
　　Dim i As Long, str As String

　　'G3:I* 範囲をクリア
　　Range("G3", Cells(Rows.Count, "I").End(xlUp)).ClearContents
　　LastO = Cells(Rows.Count, "O").End(xlUp).Row
　　'前回 O:Q列、塗りつぶしなしに
　　Range("O3:Q" & LastO).Interior.Color = xlNone
　　Range("B3:D3").Value = Cells(LastO, "O").Resize(, 3).Value
　　str = Range("B3").Value & Range("C3").Value & Range("D3").Value
　　For i = 3 To LastO - 1
　　　　If str = Cells(i, "O").Value & Cells(i, "P").Value & Cells(i, "Q").Value Then
　　　　　　LastG = Cells(Rows.Count, "G").End(xlUp).Row + 1
　　　　　　If LastG < 3 Then LastG = 3
　　　　　　Cells(LastG, "G").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value
　　　　　　Cells(i + 1, "O").Resize(, 3).Interior.Color = vbYellow
　　　　End If
　　Next
End Sub

お礼

watabe007さんいつもありがとうございます。同じ様な内容でまた質問しますのでまた是非ともご協力頂けたら幸いです。仕事や私生活にテンヤワンヤでバイタリティも萎え中々自分の作りたい物に手を着けられずの日々になりがちです

回答No.8

watabe007

>複数個あるのにG,H,Iに１つだけしか取り出されていません。
G3から下に継ぎ足すのですね
Sub Test4()
Dim LastO As Long, LastG As Long
Dim i As Long, str As String

'G3:I* 範囲をクリア
Range("G3", Cells(Rows.Count, "I").End(xlUp)).ClearContents
LastO = Cells(Rows.Count, "O").End(xlUp).Row
Range("B3:D3").Value = Cells(LastO, "O").Resize(, 3).Value
str = Range("B3").Value & Range("C3").Value & Range("D3").Value
For i = 3 To LastO
　　If str = Cells(i, "O").Value & Cells(i, "P").Value & Cells(i, "Q").Value Then
　　　　LastG = Cells(Rows.Count, "G").End(xlUp).Row + 1
　　　　If LastG < 3 Then LastG = 3
　　　　Cells(LastG, "G").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value
　　End If
Next
End Sub

お礼

お礼が遅くなりました。ありがとうございますWatabe007さん。お陰様でできました。続きがあります。
検索されて取り出された対照データがO:Qのどこから取り出されたか一見して分かりやすいようにするには色を着けたいと思っております。どのようにすればよろしいですか。また、着けられた色が、次の別の参照データで被ったりしないように前の色を消してからにしたいと思います。ご協力お願いします。

回答No.7

mt2015

ANo.1です。

> mt2015さん、ありがとうございました。(B3:D5)を(B3:D3)にして最下行だけをコピペするには何処をどう変えれば良いですか？

「最下行だけ」とはどういう意味でしょうか。
B3:D3と一致するデータが複数個所あった場合、その一番下だけを抽出対象にすると言う意味ですか。

お礼

返事遅くなりました。OPQにはマクロボタンを1度押すと新たなデータが付加されます。その新しいデータはOPQの最下行にあたります。それを、別のマクロボタンを押すと(B3:D3)にコピペがされてそれを参照してデータOPQから在るだけ探してGHIに全てコピペしたいです。

回答No.6

watabe007

Sub Test3()
　　Dim LastRow As Long, i As Long, j As Long
　　Dim flg As Boolean

　　LastRow = Cells(Rows.Count, "O").End(xlUp).Row
　　Range("B3:D3").Value = Cells(LastRow, "O").Resize(, 3).Value
　　For i = 3 To LastRow
　　　　For j = 1 To 3
　　　　　　If Range("B3:D3").Item(j) <> Cells(i, "O").Resize(, 3).Item(j) Then flg = True
　　　　Next
　　　　If flg = False Then Exit For
　　　　flg = False
　　Next
　　'G3:I3範囲をクリア
　　Range("G3:I3").ClearContents
　　Range("G3:I3").Value = Cells(i + 1, "O").Resize(, 3).Value
End Sub

お礼

返事遅くなりました。このやり方でやってみましたが対照となる物が複数個あるのにG,H,Iに１つだけしか取り出されていません。どうしたらよろしいですかまたスミマセンけどもお願いいたします。

回答No.5

watabe007

>G,H,Iにある前の抽出データをデリートしてからにしたいんですが、
ならG3:I3を固定にしてデータを入れます。
　　If Cells(i, "O").Offset(1).Value <> "" Then
　　　　Range("G3:I3").Value = Cells(i + 1, "O").Resize(, 3).Value
　　End If
End Sub

回答No.4

watabe007

>B3:D5をB3:D3にして最下行を参照にしたい場合は
と言うことは転記も抽出も１行で良いのかな
Sub Test2()
　　Dim LastRow As Long, i As Long, j As Long
　　Dim flg As Boolean

　　LastRow = Cells(Rows.Count, "O").End(xlUp).Row
　　Range("B3:D3").Value = Cells(LastRow, "O").Resize(, 3).Value
　　For i = 3 To LastRow
　　　　For j = 1 To 3
　　　　　　If Range("B3:D3").Item(j) <> Cells(i, "O").Resize(, 3).Item(j) Then flg = True
　　　　Next
　　　　If flg = False Then Exit For
　　　　flg = False
　　Next
　　If Cells(i, "O").Offset(1).Value <> "" Then
　　　　LastRow = Cells(Rows.Count, "G").End(xlUp).Row + 1
　　　　LastRow < 3 Then LastRow = 3
　　　　Cells(LastRow, "G").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value
　　End If
End Sub

お礼

Watabe007さんありがとうございます。常に新しい抽出データにしたい場合はG,H,Iにある前の抽出データをデリートしてからにしたいんですが、どのようなソースを組み足せばよろしいですか？今のままでは前のデータの下に新しいデータが継ぎ足しされる形になるんです。

回答No.3

mt2015

ANo.1です。
やっている事はNo.2の回答とほぼ同じですが、3×3のセル範囲をfunctionのサブルーチンで文字列化し、文字列同士を比較しています。

Sub Sample()
　　'最終データをB3:D5に
　　nLastRow = Range("O4").SpecialCells(xlCellTypeLastCell).Row - 2
　　Range("B3:D5").Value = Cells(nLastRow, 15).Resize(3, 3).Value

　　sTarget = fDataString(Range("B3:D5")) 'セル範囲を1つの文字列にする

　　nWriteRow = 3
　　For i = 4 To nLastRow
　　　　sCheck = fDataString(Cells(i, 15).Resize(3, 3))
　　　　'文字列にしたセル範囲同士を比較
　　　　If StrComp(sTarget, sCheck) = 0 Then
　　　　　　Cells(nWriteRow, 7).Resize(, 3).Value = Cells(i + 3, 15).Resize(, 3).Value
　　　　　　nWriteRow = nWriteRow + 1
　　　　End If
　　Next i
End Sub
Function fDataString(rRange As Range) As String
　　'セル範囲の値を1つの文字列にして返す
　　Dim r As Range
　　fDataString = ""
　　For Each r In rRange
　　　　fDataString = fDataString & r.Text & "/" '「/」は区切り文字
　　Next
End Function

お礼

mt2015さん、ありがとうございました。(B3:D5)を(B3:D3)にして最下行だけをコピペするには何処をどう変えれば良いですか？

回答No.2

watabe007

こんな感じかな？
Sub Test()
　　Dim LastRow As Long, i As Long, j As Long
　　Dim flg As Boolean

　　LastRow = Cells(Rows.Count, "O").End(xlUp).Row - 2
　　Range("B3:D5").Value = Cells(LastRow, "O").Resize(3, 3).Value
　　For i = 3 To LastRow
　　　　For j = 1 To 9
　　　　　　If Range("B3:D5").Item(j) <> Cells(i, "O").Resize(3, 3).Item(j) Then flg = True
　　　　Next
　　　　If flg = False Then Exit For
　　　　flg = False
　　Next
　　If Cells(i, "O").Offset(3).Value <> "" Then
　　　　LastRow = Cells(Rows.Count, "G").End(xlUp).Row + 1
　　　　If LastRow < 3 Then LastRow = 3
　　　　Cells(LastRow, "G").Resize(, 3).Value = Cells(i + 3, "O").Resize(, 3).Value
　　End If
End Sub

お礼

watabe007さん、いつもありがとうございます。ついでに聞きたいんですが、B3:D5をB3:D3にして最下行を参照にしたい場合は何処をどう変えれば良いですか？

回答No.1

mt2015

具体的な例が無いと良くわかりません。
添付の図の様な事でしょうか？

お礼

まさにこの通りです(T-T)気づいて貰えない心の内を悟ってもらい語って頂けたぐらいに嬉しいです。泣けてきます。

補足

VBAで教えて頂けますか？