エクセルVBAで複数の条件を満たす検索方法

質問

エクセルのVBAを使ってデータ検索を行うプログラムを作っています

"Sheet2"は下記のように、A列に生年月日、B列に住所、C列に電話番号、D列にメールアドレスが入力されています

　　　　　　　【Sheet2】
　　生年月日　　住所　　　　電話番号　　メールアドレス
　　　　A　　　　　　B　　　　　　　C　　　　　　　　D
1　1999/9/10　東京都○○　11-111-1111　aa@goo.co.jp
2　2003/2/26　大阪府○○　22-222-2222　bb@goo.co.jp
3　1985/6/22　福岡県○○　33-333-3333　cc@goo.co.jp
4　1995/4/11　愛知県○○　44-444-4444　dd@goo.co.jp

"Sheet1"のA1に生年月日、A2に住所、A3に電話番号を入力し、"Sheet2"のデータと照合して、3つの値が合致した行のD列のメールアドレスを"Sheet1"のB1に返したいと思います

上記の表だと、"Sheet1"のA1に1985/6/22、A2に福岡県○○、A3に33-333-3333と入力されている場合、B1にcc@goo.co.jpの値を返すようにしたいのです。

findを使って生年月日、住所、電話番号を検索し、行番号を取得して、3つの行番号が同じならその行番号のD列の値を返すというような方法で考えていたのですが、エラーが回避できずに困っています。
生年月日が同じ人がいたり、夫婦や親子などは住所と電話番号が同じといった場合があり、上手く検索できません。　

エラー回避の方法、もしくは他のやり方でも構いませんので
どなたかご教授願えないでしょうか？
よろしくお願いします。

回答No.3

okormazd · ベストアンサー

ANo.2です。
すみません。ミスがありました。
Sub test()

Dim sh1 As Object, sh2 As Object
Dim d1 As String, d2 As String, r As Long

Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")

r = 1
d1 = sh1.Cells(1, 1) & sh1.Cells(2, 1) & sh1.Cells(3, 1)
d2 = sh2.Cells(r, 1) & sh2.Cells(r, 2) & sh2.Cells(r, 3)
Do While d2 <> ""
If d1 = d2 Then
sh1.Cells(1, 2) = sh2.Cells(r, 4)
Exit Do
End If
r = r + 1
d2 = sh2.Cells(r, 1) & sh2.Cells(r, 2) & sh2.Cells(r, 3)
Loop

End Sub

お礼

お礼が遅れて申し訳ありませんでした。
無事にプログラム作成できました
本当に助かりました
ありがとうございました

回答No.6

kunkun_129

なんどもすみません。

d1 = Sheets("Sheet1").Cells(1, 1).value
d2 = Sheets("Sheet1").Cells(2, 1).value
d3 = Sheets("Sheet1").Cells(3, 1).value

上のところが間違いですので、差し替えて

お礼

お礼が遅れて申し訳ありませんでした。
他の回答者の方の方法でプログラムを作成しましたが
こちらの方法も試してみます
ありがとうございました

回答No.5

kunkun_129

#4の回答者です。
下記のロジックのが早く検索できます。

Dim a As Range
Dim b As Range
Dim c As Range

Dim ar As Long
Dim br As Long
Dim cr As Long

Dim d1 As string
Dim d2 As string
Dim d3 As string

l = 1

d1 = Sheets("Sheet1").Cells(1, 1).value
d2 = Sheets("Sheet1").Cells(1, 1).value
d3 = Sheets("Sheet1").Cells(1, 1).value

l = 1
Do
Set a = Sheets("Sheet2").Range("A" & l & ":A1000").Find(d1, , , xlWhole)
Set b = Sheets("Sheet2").Range("B" & l & ":A1000").Find(d2, , , xlWhole)
Set c = Sheets("Sheet2").Range("C" & l & ":A1000").Find(d3, , , xlWhole)

If a Is Nothing = True And b Is Nothing = True And c Is Nothing Then Exit Do (みつからない）

If a Is Nothing = False Then ar = a.Row Else ar = 1000
If b Is Nothing = False Then br = b.Row Else br = 1000
If c Is Nothing = False Then cr = c.Row Else cr = 1000

If ar = br And ar = cr Then Exit Do <======= 3列の行同じ(ここでみつかっている)

If l < ar Then l = ar　　　　　ここを変えた。
If l < br Then l = br
If l < cr Then l = cr

Loop

回答No.4

kunkun_129

Sheets("Sheet1").Cells(,) では、スピードがめちゃ遅いので、多いデータだと
全くつかいものになりません。

やはり、ＦＩＮＤでするべきです。

Dim a As Range
Dim b As Range
Dim c As Range

Dim ar As Long
Dim br As Long
Dim cr As Long

Dim d1 As string
Dim d2 As string
Dim d3 As string

l = 1

d1 = Sheets("Sheet1").Cells(1, 1).value
d2 = Sheets("Sheet1").Cells(1, 1).value
d3 = Sheets("Sheet1").Cells(1, 1).value

l = 1
Do
Set a = Sheets("Sheet2").Range("A" & l & ":A1000").Find(d1, , , xlWhole)
Set b = Sheets("Sheet2").Range("B" & l & ":A1000").Find(d2, , , xlWhole)
Set c = Sheets("Sheet2").Range("C" & l & ":A1000").Find(d3, , , xlWhole)

l = 65000
If a Is Nothing = True And b Is Nothing = True And c Is Nothing Then Exit Do (みつからない）

If a Is Nothing = False Then ar = a.Row Else ar = l
If b Is Nothing = False Then br = b.Row Else br = l
If c Is Nothing = False Then cr = c.Row Else cr = l

If ar = br And ar = cr Then Exit Do <======= 3列の行同じ(ここでみつかっている)

If l > ar Then e = ar
If l > br Then e = br
If l > cr Then e = cr

Loop

上のでほぼいくのでは？。デバッグはしていないが。そちらでデバッグして下さい。

注意点は下記の通りです。

１行目は空けて、２行目からデータが入っているとのこと。
また。　l = 1　は開始の行ですが、ここは１でよい。

Set a = Sheets("Sheet2").Range("A" & l & ":A1000").Find(d1, , , xlWhole)

　　Range("A" & l & ":A1000")　で指定する最終行は、最終行の値＋１になっています。

　すなわち、上のソースでは、２行目から９９９行目までデータがあるとのことになります。

回答No.2

okormazd

Sub test()

Dim sh1 As Object, sh2 As Object
Dim d1 As String, d2 As String, r As Long

Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")

d1 = sh1.Cells(1, 1) & sh1.Cells(2, 1) & sh1.Cells(3, 1)

r = 1
Do While d1 <> ""
d2 = sh2.Cells(r, 1) & sh2.Cells(r, 2) & sh2.Cells(r, 3)
If d1 = d2 Then
sh1.Cells(1, 2) = sh2.Cells(r, 4)
Exit Do
End If
r = r + 1
Loop

End Sub

回答No.1

keirika

Sub Sample()

Dim Data As Range
Dim i As Long

Set Data = Sheets("Sheet2").Range("a1").CurrentRegion

With Sheets("Sheet1")
For i = 1 To Data.Rows.Count
If .Range("a1") = Data.Cells(i, 1) And _
.Range("a2") = Data.Cells(i, 2) And _
.Range("a3") = Data.Cells(i, 3) Then
.Range("b1") = Data.Cells(i, 4)
Exit For
End If
Next i
End With

End Sub

でどうでしょう。

お礼

お礼が遅れて申し訳ありませんでした。
大変参考になりました
ありがとうございました