【マクロ】アクティブセルの２つの条件に一致する契約を特定。データを上書きするには？

【やりたい事】
アクティブセルのお客様番号と区分の２つの条件に一致している
契約を⇒I列とJ列からから検索⇒特定
●一致している⇒メッセージ表示
●該当契約なし⇒メッセージ表示

一致している場合は、以下オペ実施
●C4セル⇒K2セルへ上書き転記
●D4セル⇒L2セルへ上書き転記

ご存じの方いらっしゃいましたら、アドバイスorコードを教えて下さい

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2025/04/13 22:36

>１つ質問なのですが、郵便番号・住所を上書きするリストが

別ファイルの時は以下のように、都度、シートを指定すれば
良いのでしょうか？
>普通に動いたので、良いかとは思うのですが
ブックがあっちいったりこっちいったりするので
●注意点等あれば教えて下さい●

以下のwsとws1は、別々のブックにあるということでしょうか。
そうであれば、
①２つのブックは共に、オープンされた状態でマクロが呼び出されるのでしょうか。
②それとも、マクロが呼び出された時、別ファイルは、閉じていて、マクロがオープンするのでしょうか。

①であれば、wsがアクティブシートの状態でマクロを呼び出すので、
ws1の設定のみ行えば、問題ありません。
②であれば、別ブックをオープンすると、元々のアクティブセルの情報が失われるので、一旦その情報を記憶してから、別ブックをオープンする必要があります。その後で、アクティブセルの状態を復元し、その内容を参照するように変える必要があります。
ws⇒リスト元があるファイル
ws1⇒別ファイル

この回答へのお礼

お返事ありがとうございます
どちらも、オープンです
1番の方です
問題なさそうですね

いろいろご指導いただきまして
いつもありがとうございます

お礼日時：2025/04/13 23:28

No.1 回答者： tatsumaru77 回答日時： 2025/04/13 14:56

以下のようにしてください。

Option Explicit
Public Sub 契約検索_転記()
Dim ws As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim actrow As Long
Dim wrow As Long
Set ws = ActiveSheet
lastrow1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = ws.Cells(Rows.Count, "I").End(xlUp).Row
If ActiveCell.Row < 2 Or ActiveCell.Row > lastrow1 Or ActiveCell.Column > 4 Then
MsgBox ("アクティブセル範囲外")
Exit Sub
End If
actrow = ActiveCell.Row
For wrow = 2 To lastrow2
If ws.Cells(actrow, "A").Value = ws.Cells(wrow, "I").Value And ws.Cells(actrow, "B").Value = ws.Cells(wrow, "J").Value Then
MsgBox ("該当契約あり")
ws.Cells(wrow, "K").Value = ws.Cells(actrow, "C").Value
ws.Cells(wrow, "L").Value = ws.Cells(actrow, "D").Value
Exit Sub
End If
Next
MsgBox ("該当契約無し")
End Sub

この回答へのお礼

tatsumaru77　様
１～１０までコードご指南頂きましてありがとうございます
ちゃんと、動きました。

１つ質問なのですが、郵便番号・住所を上書きするリストが
別ファイルの時は以下のように、都度、シートを指定すれば
良いのでしょうか？

普通に動いたので、良いかとは思うのですが
ブックがあっちいったりこっちいったりするので
●注意点等あれば教えて下さい●

【別ファイルの宣言や変数には入れています】
ws⇒リスト元があるファイル
ws1⇒別ファイル

【上書きするリストが違うファイル内の場合】
For i = 2 To lastrow2

If ws.Cells(actrow, "A").Value = ws1.Cells(i, "a").Value And ws.Cells(actrow, "B").Value = ws1.Cells(i, "b").Value Then

MsgBox ("該当契約あり")

ws1.Cells(i, "c").Value = ws.Cells(actrow, "C").Value

ws1.Cells(i, "d").Value = ws.Cells(actrow, "D").Value

Exit Sub
End If

Next



【上書きするリストが同じファイル内の場合】
For wrow = 2 To lastrow2
If ws.Cells(actrow, "A").Value = ws.Cells(wrow, "I").Value And ws.Cells(actrow, "B").Value = ws.Cells(wrow, "J").Value Then
MsgBox ("該当契約あり")
ws.Cells(wrow, "K").Value = ws.Cells(actrow, "C").Value
ws.Cells(wrow, "L").Value = ws.Cells(actrow, "D").Value
Exit Sub
End If
Next

お礼日時：2025/04/13 22:15