VBAのFind関数で結合セルを検索するとヒットしない

2つのブックがあり、book1のE列の値をbook2のB列で検索し、
ヒットした行はbook1のP列の値をbook2のH列に入力したいです。
しかしbook2のB～F列の一部が結合されており、結合セルに対しては検索が機能せず、確実にある値でも「該当なし」となってしまいます。
（結合は行ごとに横方向のみ。縦結合はありません）
結合を解くと正常に動くため、それが原因なのは間違いないのですが、
フォーマット上、結合を解除しないまま入力しないとならず、行き詰まっております。
色々と調べましたが解決できず、ご存知の方いらっしゃいましたら、何卒ご教授頂けますと幸いです。

Sub test()

Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Long, r2 As Long
Dim fnd As Range
Dim sid As Variant, sname As String
Dim mes As String

Set sh1 = ActiveWorkbook.Sheets(1)
Set sh2 = Workbooks("test.xls").Sheets(1)

With sh1
For r1 = 2 To .Cells(Columns.Count, 1).End(xlUp).Row
sid = .Range("E" & r1).Value
sname = .Range("E" & r1).Offset(, 1).Value
Set fnd = sh2.Range("B:B").Find(What:=sid, LookIn:=xlValues, LookAt:=xlPart)
If fnd Is Nothing Then
mes = mes & sname & vbCrLf
Else
r2 = fnd.Row
sh2.Range("P" & r2).Value = sh1.Range("H" & r1).Value
End If
Next r1

If mes = "" Then
MsgBox "入力終了"
Else
MsgBox mes & "該当なし"
End If
End With
End Sub

No.4 回答者： fujillin 回答日時： 2022/02/20 23:35

こんばんは

FIND以外で各セルを検索する方法は既に出ているので、ご提示の方法にほぼ近い方法を・・

どこかの空き列を作業列としてB列の値を一旦コピーして、そちらの列から検索し、終わったら消去する方法です。
ご提示のコードに2行ほど追加することで、ほぼそのままで済むものと思います。
空き列がわかっていればその列に、不定の場合はUsedRange+1列目にするか、最終列（大抵は使っていない）を利用するなど。

具体的には・・
例えば、X列が空き列とわかっているとして、事前に（=ループの外で）
　sh2.Columns("X").Value = sh2.Columns("B").Value
としておけば、X列に結合のない状態でB列の値がコピーされます。
検索はこのX列に対して行い、検索が終わったら
　sh2.Columns("X").ClearContents
とすることで、X列の値はクリアされます。

No.3 回答者： Qchan1962 回答日時： 2022/02/20 22:50

こんばんは

上から合致した行№を取得する為のFindのようなので
あっさりFindを諦めて　配列で行№に相当する値を取得してみるのはどうでしょう。

Sub sample()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Long, r2 As Long, i As Long
Dim sid As Variant, sname As String
Dim mes As String
Dim Ary
Set sh1 = ActiveWorkbook.Sheets(1)
Set sh2 = Workbooks("test.xls").Sheets(1)

Ary = sh2.Range(sh2.Cells(1, 2), sh2.Cells(Rows.Count, 2).End(xlUp))
With sh1
For r1 = 2 To .Cells(Columns.Count, 1).End(xlUp).Row
sid = .Range("E" & r1).Value
sname = .Range("E" & r1).Offset(, 1).Value
r2 = 0
For i = 1 To UBound(Ary, 1)
If Ary(i, 1) Like "*" & sid & "*" Then
r2 = i
Exit For
End If
Next
If r2 = 0 Then
mes = mes & sname & vbCrLf
Else
sh2.Range("P" & r2).Value = sh1.Range("H" & r1).Value
End If
Next r1
If mes = "" Then
MsgBox "入力終了"
Else
MsgBox mes & "該当なし"
End If
End With
End Sub

xlPart・・
If Ary(i, 1) Like "*" & sid & "*" Then　については検討が必要かも

No.2 回答者： ママチャリ 回答日時： 2022/02/20 22:17

要件的に、下記のようにするとことは不可ですかね？

Set fnd = sh2.Range("B:B").Find(・・・
　　　　　　　　　　　↓
Set fnd = sh2.Range("B:F").Find(・・・

No.1 回答者： mygoonickname 回答日時： 2022/02/20 21:44

こんばんは。

セルの結合と、マクロは相性が悪く、色々とトラブルの元になりますね。
直接の回答ではありませんが、１つの解決方法としてですが、
book2のシートを新しいブックにコピーして、結合を全て解除する。
book1のE列の値を新しいブックのB列で検索し、ヒットした行はbook1の
P列の値をbook2のH列に入力する。
処理が少し面倒ですが、３つのブックをマクロで処理するが良いかと。