-PR-
pattern706

エクセルの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列の値を返すというような方法で考えていたのですが、エラーが回避できずに困っています。
生年月日が同じ人がいたり、夫婦や親子などは住所と電話番号が同じといった場合があり、上手く検索できません。 

エラー回避の方法、もしくは他のやり方でも構いませんので
どなたかご教授願えないでしょうか?
よろしくお願いします。
  • 回答数6
  • 気になる数2
  • Aみんなの回答(全6件)

    質問者が選んだベストアンサー

    • 2008-09-21 22:18:14
    • 回答No.3
    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
    お礼コメント
    お礼が遅れて申し訳ありませんでした。
    無事にプログラム作成できました
    本当に助かりました
    ありがとうございました
    投稿日時 - 2008-09-25 21:00:56
    • ありがとう数0
    -PR-
    -PR-

    その他の回答 (全5件)

    • 2008-09-24 00:49:12
    • 回答No.6
    なんどもすみません。 d1 = Sheets("Sheet1").Cells(1, 1).value d2 = Sheets("Sheet1").Cells(2, 1).value d3 = Sheets("Sheet1").Cells(3, 1).value 上のところが間違いですので、差し替えて ...続きを読む
    なんどもすみません。

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

    上のところが間違いですので、差し替えて
    お礼コメント
    お礼が遅れて申し訳ありませんでした。
    他の回答者の方の方法でプログラムを作成しましたが
    こちらの方法も試してみます
    ありがとうございました
    投稿日時 - 2008-09-25 20:59:55
    • ありがとう数0
    • 2008-09-24 00:30:02
    • 回答No.4
    Sheets("Sheet1").Cells(,) では、スピードがめちゃ遅いので、多いデータだと 全くつかいものになりません。 やはり、FINDでするべきです。 Dim a As Range Dim b As Range Dim c As Range Dim ar As Long Dim br As Long ...続きを読む
    Sheets("Sheet1").Cells(,) では、スピードがめちゃ遅いので、多いデータだと
    全くつかいものになりません。

    やはり、FINDでするべきです。

    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

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

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

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

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

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

     すなわち、上のソースでは、2行目から999行目までデータがあるとのことになります。
    • ありがとう数0
    • 2008-09-24 00:42:20
    • 回答No.5
    #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 ...続きを読む
    #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
    • ありがとう数0
    • 2008-09-21 21:04:00
    • 回答No.1
    Sub Sample() Dim Data As Range Dim i As Long Set Data = Sheets("Sheet2").Range("a1").CurrentRegion With Sheets("Sheet1") Fo ...続きを読む
    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

    でどうでしょう。
    お礼コメント
    お礼が遅れて申し訳ありませんでした。
    大変参考になりました
    ありがとうございました
    投稿日時 - 2008-09-25 21:01:47
    • ありがとう数0
    • 2008-09-21 22:13:40
    • 回答No.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") d1 = sh1.Cells(1, 1) & sh ...続きを読む
    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
    • ありがとう数0
    • 回答数6
    • 気になる数2
    • ありがとう数2
    • ありがとう
    • なるほど、役に立ったなど
      感じた思いを「ありがとう」で
      伝えてください
    • 質問する
    • 知りたいこと、悩んでいることを
      投稿してみましょう
    こんな書き方もあるよ!この情報は知ってる?あなたの知識を教えて!
    このQ&Aにはまだコメントがありません。
    あなたの思ったこと、知っていることをここにコメントしてみましょう。

    関連するQ&A

    -PR-
    -PR-

    その他の関連するQ&Aをキーワードで探す

    別のキーワードで再検索する
    -PR-
    -PR-
    -PR-

    特集


    成功のポイントとは?M&Aで経営の不安を解決!

    -PR-

    ピックアップ

    -PR-
    ページ先頭へ