VBA Dictionary (高速のVLOOKUP版)

Option Explicit
Public Const SH_AB As String = "AB表"

Public Sub MergeMemoByID()

    Dim wsAB As Worksheet
    Dim wsB As Worksheet
    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim arrA As Variant 'ID取得用（B～E列）
    Dim arrB As Variant '番号・備考取得用（H～J列）
    Dim arrF As Variant '備考用（F列）
    Dim dict As Object
    Dim i As Long, key As String
    Dim dataCountA As Long, dataCountB As Long
    
    Set wsAB = ThisWorkbook.Worksheets(SH_AB)
   
   With wsAB
        lastRowA = .Cells(.Rows.Count, "C").End(xlUp).row
        lastRowB = .Cells(.Rows.Count, "H").End(xlUp).row
    End With
    
    If lastRowA < 4 Or lastRowB < 4 Then
        MsgBox "データが不足しています。", vbExclamation
        Exit Sub
    End If
    
    'データ行数（4行目以降）
    dataCountA = lastRowA - 3
    dataCountB = lastRowB - 3
    
    '配列取得
    With wsAB
        arrA = .Range("B4").Resize(dataCountA, 4).Value
        arrF = .Range("F4").Resize(dataCountA, 1).Value
        arrB = .Range("H4").Resize(dataCountB, 3).Value
    End With
    
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    '--- B表 → Dictionary ---
    For i = 1 To dataCountB
        key = Trim(CStr(arrB(i, 1)))
        If key <> "" Then dict(key) = arrB(i, 3)
    Next i
    
    '--- A表 → F列更新 ---
    For i = 1 To dataCountA
        key = Trim(CStr(arrA(i, 2))) 'ID: C列
        If key <> "" Then
            If dict.Exists(key) Then
                arrF(i, 1) = dict(key)
                '空白セルのみ値を取得
'                If Trim(arrF(i, 1)) = "" Then '空だけ上書き
'                    arrF(i, 1) = dict(key)
'                End If
            End If
        End If
    Next i
    
    '書き戻し（F列のみ）
    wsAB.Range("F4").Resize(dataCountA, 1).Value = arrF
    
    MsgBox "備考欄の更新が完了しました。", vbInformation
End Sub

Option Explicit
Public Const SH_AB As String = "AB表"

Public Sub MergeMemoByID()

    Dim wsAB As Worksheet
    Dim wsB As Worksheet
    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim arrA As Variant 'ID取得用（B～E列）
    Dim arrB As Variant '番号・備考取得用（H～J列）
    Dim arrF As Variant '備考用（F列）
    Dim dict As Object
    Dim i As Long, key As String
    Dim dataCountA As Long, dataCountB As Long
    
    Set wsAB = ThisWorkbook.Worksheets(SH_AB)
   
   With wsAB
        lastRowA = .Cells(.Rows.Count, "C").End(xlUp).row
        lastRowB = .Cells(.Rows.Count, "H").End(xlUp).row
    End With
    
    If lastRowA < 4 Or lastRowB < 4 Then
        MsgBox "データが不足しています。", vbExclamation
        Exit Sub
    End If
    
    'データ行数（4行目以降）
    dataCountA = lastRowA - 3
    dataCountB = lastRowB - 3
    
    '配列取得
    With wsAB
        arrA = .Range("B4").Resize(dataCountA, 4).Value
        arrF = .Range("F4").Resize(dataCountA, 1).Value
        arrB = .Range("H4").Resize(dataCountB, 3).Value
    End With
    
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    '--- B表 → Dictionary ---
    For i = 1 To dataCountB
        key = Trim(CStr(arrB(i, 1)))
        If key <> "" Then dict(key) = arrB(i, 3)
    Next i
    
    '--- A表 → F列更新 ---
    For i = 1 To dataCountA
        key = Trim(CStr(arrA(i, 2))) 'ID: C列
        If key <> "" Then
            If dict.Exists(key) Then
                arrF(i, 1) = dict(key)
                '空白セルのみ値を取得
'                If Trim(arrF(i, 1)) = "" Then '空だけ上書き
'                    arrF(i, 1) = dict(key)
'                End If
            End If
        End If
    Next i
    
    '書き戻し（F列のみ）
    wsAB.Range("F4").Resize(dataCountA, 1).Value = arrF
    
    MsgBox "備考欄の更新が完了しました。", vbInformation
End Sub