エクセルＶＢＡ 検索機能を利用したデータ抽出方法

質問

■主な目的
顧客の住所データベースのうち
市町村の合併等により変更されたものを
抽出します。

自分で考えたのですが行き詰りました。
誰か助けてください。

■エクセルファイルのシート構成と処理方法
シートは３枚あります。
(1)sheet１　旧住所一覧
Ａ列に旧住所の一覧が約60行にわたって記載されいてます。
西白河郡表郷村
大野郡和泉村
神崎郡神崎町
・
・
(2)sheet2 顧客データベース
Ａ列に顧客コード、Ｂ列に顧客名、Ｃ列に郵便番号、Ｄ列に顧客住所が約7000行にわたって記載されています。

(3)sheet3 抽出用シート
sheet1のＡ１の値をsheet2のＤ列を対象として検索をかけ、該当した行（Ａ～Ｄ列）をそのままsheet3にコピーし、あとはそれを繰り返します。

私のやり方は
cells(行、列)、ForNext、seach関数等を組み合わせてやろうとしましたが、serch関数のセル位置取得がRange("行列")形式になり、それをどうやったらsheet3に行をＡ～Ｄまで丸ごとコピーできるのかわからず降参しました。

よろしくおねがいします。

回答No.1

Wendy02 · ベストアンサー

こんばんは。

以下は、私自身としては、二案を考えましたが、どちらも、あまり良い出来とは言えません。Search関数を使ったコードを別案として掲示しましたので、とりあえず参考にしてください。

検索は、Findメソッドのほうは、検索を、xlPart（部分）、Search関数側は、ワイルドカードをつけました。

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim FindRng As Range

Sub TestSample()
Dim SearchRng As Range
Dim r As Range

Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
Set FindRng = sh2.Range("D1", sh2.Range("D65536").End(xlUp))
Set SearchRng = sh1.Range("A1", sh1.Range("A65536").End(xlUp))
For Each r In SearchRng
　If Not IsEmpty(r) Then
　　 s_Find_Copy r.Value
　　　s_SearchFunctionMethond (r.Value)　　''別案のサブルーチン
　End If
Next r
　Set FindRng = Nothing
　Set SearchRng = Nothing
　Set sh1 = Nothing
　Set sh2 = Nothing
　Set sh3 = Nothing
End Sub

Sub s_Find_Copy(SearchWord As String)
'サブルーチン
Dim myFirstAddress As String
Dim c As Range
　Set c = FindRng.Find( _
　　 What:=SearchWord, _
　　 LookIn:=xlValues, _
　　 LookAt:=xlPart, _
　　 SearchOrder:=xlByColumns, _
　　 SearchDirection:=xlNext)
　If Not c Is Nothing Then
　　　myFirstAddress = c.Address
　　　Do
　　'Sheet3の二行目から
　　　c.Offset(, -3).Resize(, 4).Copy sh3.Range("A65536").End(xlUp).Offset(1)
　　　Set c = FindRng.FindNext(c)
　　　Loop Until c Is Nothing Or c.Address = myFirstAddress
　　End If
End Sub

'----------------------------------
''Search関数を使った別案のサブルーチン
'-----------------------------------

Sub s_SearchFunctionMethond(SearchWord As String)
Dim ar() As Variant
Dim myData() As Long
Dim i As Long
Dim j As Long
　ar = Evaluate("INDEX(SEARCH(""" & SearchWord &"*" & """,Sheet2!D1:D7000),0,1)")
Do Until i = UBound(ar)
　i = i + 1
　If Not IsError(ar(i, 1)) Then
　 ReDim Preserve myData(j)
　 myData(j) = i
　 j = j + 1
　End If
Loop
For j = LBound(myData) To UBound(myData)
　'Sheet3の二行目から
　sh2.Cells(myData(j), 1).Resize(, 4).Copy sh3.Range("A65536").End(xlUp).Offset(1)
Next j
Erase myData
End Sub

お礼

いつもお世話になっております。
オフセット使ってコピーっていう方法もあるんですかー。
これを元にがんばってみます。
ありがとうございました。