■主な目的
顧客の住所データベースのうち
市町村の合併等により変更されたものを
抽出します。
自分で考えたのですが行き詰りました。
誰か助けてください。
■エクセルファイルのシート構成と処理方法
シートは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まで丸ごとコピーできるのかわからず降参しました。
よろしくおねがいします。
No.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
いつもお世話になっております。
オフセット使ってコピーっていう方法もあるんですかー。
これを元にがんばってみます。
ありがとうございました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) Excelにて、行の最後のセルの値をコピーして別sheetに張りつけるVBAコードをご教授願います 3 2022/11/20 14:35
- Visual Basic(VBA) 改行ごとに行を追加し、数量を分割 4 2023/07/11 16:39
- Visual Basic(VBA) 指定月分の顧客データファイルを統合して並べ替え、所定の場所に貼り付ける 3 2022/09/10 07:55
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Visual Basic(VBA) 指定月分の顧客データファイルを統合して並べ替え、所定の場所に貼り付ける (再質問) 4 2022/09/14 22:51
- Visual Basic(VBA) Sheet「状況」から、分類の年齢別カウント数をSheet「D表」へ転記する下記マクロを作っています 7 2022/12/14 17:57
- Excel(エクセル) SUMIFSと日付変換 10 2023/04/16 15:38
- その他(プログラミング・Web制作) pythonでクラスで複数のメソッドを利用する方法 2 2022/04/15 04:17
- Visual Basic(VBA) まとめシートから集計シートへA列のコードが一致したら1行コピーするマクロをネット上で見つけました。こ 1 2022/08/30 14:11
- Visual Basic(VBA) Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Worksheets メソッドは失敗しま...
-
vba 2つの条件が一致したら...
-
Cellsのかっこの中はどっちが行...
-
【VBA】2つのシートの値を比較...
-
データグリッドビューの一番最...
-
Excelで、あるセルの値に応じて...
-
マクロ 最終列をコピーして最終...
-
DataGridViewに空白がある場合...
-
VBAで、特定の文字より後を削除...
-
rowsとcolsの意味
-
B列の最終行までA列をオート...
-
VBAを使って検索したセルをコピ...
-
VBAで、離れた複数の列に対して...
-
マクロ 関数を使った抽出でエラ...
-
IIF関数の使い方
-
VBAで重複データを確認したい
-
Changeイベントでの複数セルの...
-
VBAのFind関数で結合セルを検索...
-
エクセル アクティブセルから...
-
文字列の結合を空白行まで実行
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Worksheets メソッドは失敗しま...
-
Excelで、あるセルの値に応じて...
-
B列の最終行までA列をオート...
-
vba 2つの条件が一致したら...
-
Cellsのかっこの中はどっちが行...
-
VBAを使って検索したセルをコピ...
-
VBAのFind関数で結合セルを検索...
-
文字列の結合を空白行まで実行
-
IIF関数の使い方
-
【VBA】2つのシートの値を比較...
-
マクロ 最終列をコピーして最終...
-
Changeイベントでの複数セルの...
-
VBA 何かしら文字が入っていたら
-
URLのリンク切れをマクロを使っ...
-
エクセルVBAにて =A1=B1とすれ...
-
VBAでのリスト不一致抽出について
-
データグリッドビューの一番最...
-
マクロについて。S列の途中から...
-
VBA UserFormからの転記で
-
targetをA列のセルに限定するに...
おすすめ情報