プロが教えるわが家の防犯対策術!

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

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

■エクセルファイルのシート構成と処理方法
シートは3枚あります。
(1)sheet1 旧住所一覧
A列に旧住所の一覧が約60行にわたって記載されいてます。
西白河郡表郷村
大野郡和泉村
神崎郡神崎町


(2)sheet2 顧客データベース
A列に顧客コード、B列に顧客名、C列に郵便番号、D列に顧客住所が約7000行にわたって記載されています。

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

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

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

A 回答 (1件)

こんばんは。



以下は、私自身としては、二案を考えましたが、どちらも、あまり良い出来とは言えません。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
    • good
    • 0
この回答へのお礼

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

お礼日時:2005/11/13 16:31

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!