『4つのセルが一致したら、指定したセルの値を返す』（ミライ）
シート1のC、D、E、Fの横並びの4つセルの値が、
シート2のB、C、E、Fと一致したら、H＋Iの値をシート1のT列に出したいのですが、
1つの計算式でやる事は可能でしょうか？
補足としまして、
・全て数字かアルファベットです。
・行数は〜6000位あります。
・シート2のHとI列には後ろに不要なスペースが何個か入っていて、
置換すれば良いと思っていたのですが、データを更新していくらしく
できれば手作業なしが良いとの事でした。
※更新は内容のみで、行列数は変わらない
シート1
1 A B C D E F ・・・ T 2 0011 1160 0011 1260 FVR120 3 0001 0200 0001 0008 UND60 4 0180 0200 0181 0340 LVD180 5 6492 1BF5 6493 1BF6 FVR72
シート2
1 A B C D E F ・・・ H I 2 0180 0200 0181 0340 LVD 180 3 6492 1BF5 6493 1BF6 FVR 72 4 0011 1160 0011 1260 FVR 120 5 0001 0200 0001 0008 UND 60
わかる方がいらっしゃいましたら、教えて頂ければと思います。
よろしくお願い致します。
＜ 使用 Excel：unknown、使用 OS：unknown ＞
Windows10、エクセル2019を使用しています。
（ミライ） 2024/07/19(金) 01:20:11
(1) [0011]というデータがあることから考えて、すべて【文字列】と考えて差し支えないですよね？
(2) 「C、D、E、F」と「B、C、E、F」という順番もそのまま合致するものが対象と考えて差し支えないですよね？
(3) 「シート2のHとI列には後ろに不要なスペースが何個か入っていて置換すれば〜」
いまいち理解できませんが、シート1に出力するときはスペースは削ってよいということですよね？
（もこな２） 2024/07/19(金) 08:07:39
(1)はい。全て文字列になっています。
(2)はい。横並び順もまんま合致する物が対象になります。
(3)はい。シート1へはスペースなしで出したいです。
よろしくお願いします。
（ミライ） 2024/07/19(金) 09:08:04
Option Explicit
Sub CompareAndMerge()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRW1 As Long, LRW2 As Long
Dim i As Long, j As Long
Dim MgdValue As String
' Sheetの設定
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
' 各Sheetの最終行を取得
LRW1 = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
LRW2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
' Sheet1の各行をループ
For i = 1 To LRW1
' Sheet2の各行をループ
For j = 1 To LRW2
' 4つのセルの値が一致するかチェック
If ws1.Cells(i, "C").Value = ws2.Cells(j, "B").Value And ws1.Cells(i, "D").Value = ws2.Cells(j, "C").Value And ws1.Cells(i, "E").Value = ws2.Cells(j, "E").Value And ws1.Cells(i, "F").Value = ws2.Cells(j, "F").Value Then
' HとIの値をマージ
MgdValue = ws2.Cells(j, "H").Value & ws2.Cells(j, "I").Value
' 不要スペースを削除
MgdValue = Replace(MgdValue, " ", "")
' マージした値をSheet1のT列に書き出す
ws1.Cells(i, "T").Value = MgdValue
' 一致が見つかったらSheet2のループを抜ける
Exit For
End If
Next j
Next i
MsgBox "処理が完了しました。", vbInformation
End Sub
（暇な人） 2024/07/19(金) 10:44:56
6000行ですか。 とすると、 ・シート２のデータをdictinaryに突っ込んで、 ・シート１のデータがdictinaryにあるかどうかを確認する といった方法が速度的には有利かも知れません。 まあ、そう急ぐようなことでもないですけどねえ。
4つのANDは入れ子にしたほうが速くなるとか、 そんなことも脳裏を掠めるが、それも大した話じゃない気がしてきました。
（xyz） 2024/07/19(金) 12:04:06
■１
もう少しスマートな方法があるかもしれませんが、単純にXLOOKUP関数を使って↓のようにしてはどうでしょうか？
T1セルに↓を記述（例示のように2行目からが正しい場合は適宜修正してください） =SUBSTITUTE( XLOOKUP( C1:C4&"-"&D1:D4&"-"&E1:E4&"-"&F1:F4, シート2!$B$1:$B$6000&"-"&シート2!$C$1:$C$6000&"-"&シート2!$E$1:$E$6000&"-"&シート2!$F$1:$F$6000, シート2!$H$1:$H$6000&シート2!$I$1:$I$6000), " ","")
※ Microsoft365でテストしているので、2019はスピル非対応だったらごめんなさい
↓でも同じ結果は得られましたがたいして短くならなかった（むしろ長くなった）ので
ボツにしましたが、検索値のほうだけ使用するのはアリかもしれません。
=SUBSTITUTE(
XLOOKUP(
BYROW(C1:F4, LAMBDA(row, TEXTJOIN("-", TRUE, row))),
BYROW(シート2!B1:C6000,LAMBDA(row,TEXTJOIN("-",TRUE,row)))&"-"&BYROW(シート2!E1:F6000,LAMBDA(row,TEXTJOIN("-",TRUE,row))),
シート2!$H$1:$H$6000&シート2!$I$1:$I$6000),
" ","")
■２
トピ主が希望しているかわからないので検討していませんが、VBAでやるなら2重ループで総当たりするより、一旦ディクショナリを作ってそこから導いた方がよいような気がします。
ついでに言うと結果出力も配列にためておいて一気に書き出した方が速度的に有利だとおもいます。
（もこな２ ） 2024/07/19(金) 12:06:22
2019ですと、XLOOKUPは使えないですね。むろんLAMBDAとかも。
>1つの計算式でやる事は可能でしょうか？ 作業列を作れば、VLOOKUP関数でできますよ。そういう方向でトライされたらいかがですか？
（xyz） 2024/07/19(金) 12:23:19
Sub CompareAndMerge_2()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LRW1 As Long, LRW2 As Long
Dim i As Long, j As Long
Dim MgdValue As String
Dim dict As Object
Dim key As String
Dim results() As Variant
' Sheetの設定
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
' 各Sheetの最終行を取得
LRW1 = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
LRW2 = ws2.Cells(ws2.Rows.Count, "B").End(xlUp).Row
' ディクショナリの初期化
Set dict = CreateObject("Scripting.Dictionary")
' Sheet2のデータをディクショナリに格納
For j = 1 To LRW2
key = ws2.Cells(j, "B").Value & "|" & _
ws2.Cells(j, "C").Value & "|" & _
ws2.Cells(j, "E").Value & "|" & _
ws2.Cells(j, "F").Value
MgdValue = Replace(ws2.Cells(j, "H").Value & ws2.Cells(j, "I").Value, " ", "")
dict(key) = MgdValue
Next j
' 結果を格納する配列の初期化
ReDim results(1 To LRW1, 1 To 1)
' Sheet1のデータを処理
For i = 1 To LRW1
key = ws1.Cells(i, "C").Value & "|" & _
ws1.Cells(i, "D").Value & "|" & _
ws1.Cells(i, "E").Value & "|" & _
ws1.Cells(i, "F").Value
If dict.Exists(key) Then
results(i, 1) = dict(key)
Else
results(i, 1) = ""
End If
Next i
' 結果を一括でSheet1のT列に書き出す
ws1.Range("T1:T" & LRW1).Value = results
MsgBox "処理が完了しました。", vbInformation
End Sub （暇な人） 2024/07/19(金) 12:27:57
教えて頂いた事、この後やってみます。
途中解らなくなって手詰まる事があったらまた質問させてください。
できた時にもご報告させて頂きますね。
（ミライ） 2024/07/19(金) 12:53:46
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.