エクセルVBAで2つの条件が一致すれば結果を転記

質問

エクセルVBAの書き方を教えてください。

以下3つのエクセルファイルがあります。
・F依頼（使うSheet：ナンバリング
・F結果（使うSheet：OKリスト
・F回答（使うSheet：

F結果の「OKリスト」シートのA列3行目に結果が入っています。

　　　　A列　　　　　　　　　B列　　　　　C列
3行目　OK（結果）　　　　12345678　　　　9012

F依頼の「ナンバリング」シートには、過去からの番号が書き続けられています。

　　　 A列　　　　　　B列　　　　　C列　　　　　D列
2行目　日付　　　　12345678　　　　9012　　　　OK（結果）

OKリストのB&Cの12桁をナンバリングシートのB&Cから検索し
一致するものがあれば、ナンバリングシートのD列（結果）にOKリストのA列（結果）を
貼り付けたいです。

回答No.9

kkkkkm · ベストアンサー

とりあえず簡単に思いつくことで
マッチングかけた結果が「ナンバリング」シートのデータ数
とも考えられるので
としたら

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh1R As Range, Sh2R As Range
Dim mCount As Long, mTotal As Long
Dim Sh1FRow As Long, Sh2FRow As Long

Set Sh1 = Workbooks("F結果.xlsm").Sheets("OKリスト")
Set Sh2 = ThisWorkbook.Sheets("ナンバリング")

Sh1FRow = 3 '「OKリスト」シートのデータが始まる行
Sh2FRow = 2 '「ナンバリング」シートのデータが始まる行

mTotal = Sh2.Cells(Rows.Count, "B").End(xlUp).Row - Sh2FRow + 1

mCount = 0
For Each Sh1R In Sh1.Range(Sh1.Cells(Sh1FRow, "B"), Sh1.Cells(Rows.Count, "B").End(xlUp))
For Each Sh2R In Sh2.Range(Sh2.Cells(Sh2FRow, "B"), Sh2.Cells(Rows.Count, "B").End(xlUp))
If Sh2R.Value = Sh1R.Value And _
Sh2R.Offset(0, 1).Value = Sh1R.Offset(0, 1).Value Then
Sh2R.Offset(0, 2).Value = Sh1R.Offset(0, -1).Value
mCount = mCount + 1
Exit For
End If
Next
Next
MsgBox mTotal & " 件 マッチング" & vbCrLf & _
mCount & " 件 一致処理" & vbCrLf & _
mTotal - mCount & " 件 不一致未処理"

Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.8

kkkkkm

No7はなんか違う気がしてきました。
未処理とかは「ナンバリング」シートのOKが付かなかった数のような気もして、マッチングかけた結果もよくわからなくなりました。

回答No.7

kkkkkm

> 例えば「○件マッチングかけた結果、○件一致処理、○件不一致未処理」のような具合だと一番助かるのですが。

マッチングかけた結果は実際に検索したデータ数ということでしょうか。
データの一番最初でマッチした場合、その後幾らデータがあっても検索はしませんから、たとえばOKリスト(1個しかなかったとして)のデータがナンバリング(1000個)の先頭にマッチした場合実際の検索は1回になります。

ただ、上記ではなくOKリスト(たとえば10個)をナンバリング(たとえば1000個)すべて検索したこととして10000回として計算するという気もしますのでその場合として

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh1R As Range, Sh2R As Range
Dim mCount As Long, mTotal As Long
Dim Sh1FRow As Long, Sh2FRow As Long

Set Sh1 = Workbooks("F結果.xlsm").Sheets("OKリスト")
Set Sh2 = ThisWorkbook.Sheets("ナンバリング")

Sh1FRow = 3 '「OKリスト」シートのデータが始まる行
Sh2FRow = 2 '「ナンバリング」シートのデータが始まる行

mTotal = (Sh1.Cells(Rows.Count, "B").End(xlUp).Row - Sh1FRow + 1) * _
(Sh2.Cells(Rows.Count, "B").End(xlUp).Row - Sh2FRow + 1)
mCount = 0
For Each Sh1R In Sh1.Range(Sh1.Cells(Sh1FRow, "B"), Sh1.Cells(Rows.Count, "B").End(xlUp))
For Each Sh2R In Sh2.Range(Sh2.Cells(Sh2FRow, "B"), Sh2.Cells(Rows.Count, "B").End(xlUp))
If Sh2R.Value = Sh1R.Value And _
Sh2R.Offset(0, 1).Value = Sh1R.Offset(0, 1).Value Then
Sh2R.Offset(0, 2).Value = Sh1R.Offset(0, -1).Value
mCount = mCount + 1
Exit For
End If
Next
Next
MsgBox mTotal & " 件 マッチング" & vbCrLf & _
mCount & " 件 一致処理" & vbCrLf & _
mTotal - mCount & " 件 不一致未処理"

Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.6

imogasi

#2です。
方法は
（１）２列データを結合して１列のデータを作る方法。この列に対してMATCH関数などで検索。VBAではない。
（２）SQLを使う方法　ExcelVBAの進んだ方法
（３）VBAでフィルタ機能を使う方法
の（３）の、フィルタ（濾して残ったものを）を使う方法がある。
この質問の課題が、並みのフィルタのVBAコード例と違う、特徴は、２条件が、同一シートの別列を見る、とういう特徴です。
その場合
質問とは違う、勝手な例データですが、
シート名はSheet1、Sheet2とすること。下記VBAコードを実行するためには。
元データ
Sheet1のB、C、D列で
項目a 項目ｂ
aaa111 12 dd
aaa112 23 t
aaa113 23 s
aaa114 45 f
aab111 15 d
aab112 23 s
aab113 11 e
aab114 12 t
aab115 15 y
aac111 16 ｋ
aac112 11 k
aac113 13 h
aac114 14 f
aab111 15 n
aab119 15 m
aaa112 24 q
aac111 17 w
aad1234 29 z
ーー
検索するデータ指定データ
Sheet2　B,C列に
項目１ 項目２
aac111 16 ｋ
aab111 15
aab119 15 m
aaa112 23 t
aaa113 23 s
aab114 12 t
aac113 13 h
aac114 14 f
D列は、当プログラム実行結果です。
VBAコードは
標準モジュールに
Sub Macro1()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Set sh3 = Worksheets("Sheet3")
'------Sheet2の最下行番号取得
sh2L = sh2.Range("A100000").End(xlUp).Row
sh1.Activate
sh3.Cells.Clear
'---Sheet2の各行について
For i = 2 To sh2L 'Sheet2の各行のデータについて
'---Sh2の毎行処理前に,Sh1フィルターモード解除
If sh1.AutoFilterMode Then
sh1.AutoFilterMode = False
End If
MsgBox "A" '進行を止めて、Sh1全行対象になっているか確認用
'---　Sheet2から、条件データ２項目取得
j1 = sh2.Cells(i, "A") '条件１データ
j2 = sh2.Cells(i, "B") '条件２データ
'-----Sheet1で、フィルタ実行
sh1.Activate
sh1.Select
'---第1項目でフィルタ
sh1.Range("B1").AutoFilter Field:=1, Criteria1:=j1 'Field:の1はRange("B1").CurrentRegion.Selectの中での列番号
k = Application.WorksheetFunction.Subtotal(3, sh1.Range("B:B")) 'SUBTOTAL関数で見えている行数取得
MsgBox j1 & "は" & k & "件" '見出し行の１件を含んだ数

' MsgBox sh3.Cells(2, "C")
'MsgBox Range("B1").CurrentRegion.Cells(1, 2)
'---第2項目でフィルタ　＝ 第1項目でフィルタ結果に対してさらに重ねて絞り込み
sh1.Range("B1").AutoFilter Field:=2, Criteria1:=j2
k = Application.WorksheetFunction.Subtotal(3, sh1.Range("B:B"))
MsgBox j2 & "は" & k & "件" '見出し行の１件を含んだ数
sh1.Range("B1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy sh3.Range("A1")
If k = 2 Then '該当が１行なら
sh2.Cells(i, "C") = sh3.Cells(2, "C")

End If
'---
Next i
'-----
sh1.AutoFilterMode = False
End Sub
注意
本番では、テストにおける、確認用のMsgboxの行は削除すること。
Sheet2にある行数が何万もあると、実行時間が多少かかるかも。
フィルタの関連でScreenUpdating=Falseを入れるのは、だめかもしれない。
上記のデータ例で
aab111 15の号は空白だが、該当が２件三方tので、設定処理をスキップした。
希望にあわせてプログラム修正が必要。
該当件数を調べるのにSUBTOTAL関数を使っているのは、やや
技巧的と思う。
全般に、初心者には無理な、課題だとは思う。

回答No.5

kkkkkm

B、C列が個々には重複しているとのことなので、FindのままFind～FindNextでいけますが、以前FindNext使うと何かおかしいことがあるというのをどこかで見たことあるのででFindはやめて、多重ループで総当たりです。
B、C列の組み合わせが見つかるとその時点で中のループから外のループへ抜けます(組み合わせの重複がないのでそれ以上探す必要がない)ので無駄にループはしないと思います。
それぞれB列の最終行までループします。
気になるのはC列の連番０００１で頭を0で埋めていますが片方が文字で0001、片方が書式設定で数値の1を0001表示にしている場合は見つからないと思います。

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Sh1R As Range, Sh2R As Range

Set Sh1 = Workbooks("F結果.xlsm").Sheets("OKリスト")
Set Sh2 = ThisWorkbook.Sheets("ナンバリング")

For Each Sh1R In Sh1.Range(Sh1.Cells(3, "B"), Sh1.Cells(Rows.Count, "B").End(xlUp))
For Each Sh2R In Sh2.Range(Sh2.Cells(2, "B"), Sh2.Cells(Rows.Count, "B").End(xlUp))
If Sh2R.Value = Sh1R.Value And _
Sh2R.Offset(0, 1).Value = Sh1R.Offset(0, 1).Value Then
Sh2R.Offset(0, 2).Value = Sh1R.Offset(0, -1).Value
Exit For
End If
Next
Next
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

補足

回答ありがとうございます！
型の問題ですすめませんでしたが、漸くそちらも解決し、無事にまわりました！！

因みに、貼り付け結果をメッセージボックスに表示させることは可能でしょうか？

例えば「○件マッチングかけた結果、○件一致処理、○件不一致未処理」のような具合だと一番助かるのですが。。

回答No.4

kkkkkm

No3の
FindにLookAt:=xlWhole(完全一致)が抜けてました。

Set FRange = Sh2.Range(Sh2.Cells(2, "B"), Sh2.Cells(Rows.Count, "B").End(xlUp)).Find(FNo, LookIn:=xlValues, LookAt:=xlWhole)

回答No.3

kkkkkm

No1です
疑問だけ投げかけても…なので
一番単純な方法の例です。
ファイル名は
F結果.xlsm(VBAはこちらに記載)
F依頼.xlsx
B列、C列のデータはともに重複しない 文字と数値が混在の可能性あり
OKリストは3行目だけ。
ファイルはすべて開いている
という条件です。

Sub Test()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim FRange As Range
Dim FNo As Variant

Set Sh1 = ThisWorkbook.Sheets("OKリスト")
Set Sh2 = Workbooks("F依頼.xlsx").Sheets("ナンバリング")

FNo = Sh1.Cells(3, "B").Value
Set FRange = Sh2.Range(Sh2.Cells(2, "B"), Sh2.Cells(Rows.Count, "B").End(xlUp)).Find(FNo, LookIn:=xlValues)
If Not FRange Is Nothing Then
If FRange.Offset(0, 1).Value = Sh1.Cells(3, "C").Value Then
FRange.Offset(0, 2).Value = Sh1.Cells(3, "A").Value
End If
End If
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

回答No.2

imogasi

エクセルのVBAでは、検索はRange.Findを使うことになると思います。
しかし本質問は、検索文字列や検索するデータが２列、隣接列とはいえ
２列（B,C列）に分かれている。
ーー
Accessのようなデータベースでは、直截に言えば、SQLでは
、２フィールドの各条件をWhereに２つ並べて表現できます。
Excelでも、SQLを使うなら、MSQueryやＡＤＯを使う方法があります。
どうしますか。
ーー
上記ソフトを使わないなら、（検索されるシートの方で）２列の文字列を結合する
ための列に結合情報を作って、そこで検索すればよい。
探す方は、検索のつど２列を＆で結合するデータを作ればよい。

ーー
稀なケースですが（あまり神経質にならなくてよいが）
その時、２項目Ｘ，Yを＆で結合すると別のものが同じになる恐れ（可能性）があれば
結合に、X,Yとも定桁結合をすべきです。

ここがポイントでこれの決心がつけば、WEBでFindのコードを探せば
沢山あるから、探して勉強して。
１検索につき、該当が２件以上なさそうな質問ぶりなので簡単でしょう。

回答No.1

kkkkkm

ファイル名は
F結果.xlsx
F依頼.xlsx
なのでしょうか。どちらのファイルにVBAを記載するのでしょうか。
B列のデータは重複しますか 数値だけですか文字と数値が混在しますか
C列のデータは重複しますか 数値だけですか文字と数値が混在しますか
OKリストは3行目だけですかそれとも3行目以降も下に続いていてそれをすべて検索しますか。

とりあえずこれだけ疑問が出ました。

補足

回答ありがとうございます！
F依頼にVBAを追加しようと思っています。

F結果のファイルを開く（フォルダ/ファイル名曖昧指定/ファイルPW入力）というところまで本を見ながら
何とかVBA入力しました。

B列は重複します。必ず数字になります。
BとC列の組み合わせ数値としては重複はしてはならないはずのルールになっています。
B列１２３４５６７８（固定）C列０００１（連番）
しかし、C列が９９９９まで連番使用されると
B列が新たに採番され別の固定８桁になり、またC列に新たな連番が採番されます。

OKリストは３行目からスタートし、１００行までいくことはありませんが毎日件数が変動します。