【マクロ・VBA】Dictionary マッチング（突合）／キーとアイテム

Sub キーとアイテム基シート転記()

With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

'基ファイル
Dim wb1 As Workbook
Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
'Set ws1 = ActiveSheet
Set ws1 = wb1.Worksheets("検索")
Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'基ファイル処理
ws1.Range("F2").CurrentRegion.Offset(1.1).Clear

'基ファイル文字列変換(Cstr関数)
Dim g As Long

g = 2
Do Until g = LastRow1 + 1
    DoEvents
        'Dim strNum As String
        Num = ws1.Cells(g, 1)
        strNum = CStr(Num)
        ws1.Cells(g, 1) = strNum
 
            '----------
            '型Tを調べる方法（VarType関数）8：文字列
            'Debug.Print VarType(strNum), TypeName(Str(Num))
            '----------

            'ステータスバーへの表示更新
            Application.StatusBar = g & "/" & LastRow1 - 1 & " を完了"
g = g + 1
Loop

            'ステータスバーへの表示更新終了
            Application.StatusBar = False

'相手ファイル
Dim FName As String
Dim wb4 As Workbook
Dim ws4 As Worksheet
Dim LastRow4 As Long

MsgBox "「ファイル選択」選択"
FName = Application.GetOpenFilename("Microsoft Excelブック,*.xls*")

    If FName <> "False" Then
        Set wb4 = Workbooks.Open(FName)
        Set ws4 = wb4.Worksheets(1)
        LastRow4 = ws4.Cells(Rows.Count, 2).End(xlUp).Row
    Else
        MsgBox "file未指定 "
    End
    End If

'相手ファイル文字列変換(Cstr関数)
'Dim g As Long
g = 2
Do Until g = LastRow4 + 1
    DoEvents

    'Dim strNum As String
    Num = ws4.Cells(g, 1)
    strNum = CStr(Num)
    ws4.Cells(g, 1) = strNum
        '----------
        '型Tを調べる方法（VarType関数）8：文字列
        'Debug.Print VarType(strNum), TypeName(Str(Num))
        '----------
        'ステータスバーへの表示更新
        Application.StatusBar = g & "/" & LastRow4 - 1 & " を完了"
g = g + 1
Loop

        Application.StatusBar = False   'ステータスバーへの表示更新終了

'処理
Dim myDic As Object, myKey
Dim c, myVal
Dim i As Long
Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To LastRow4
    On Error Resume Next
    If Not myDic.Exists(ws4.Cells(i, 1).Value) Then
        myDic.Add (ws4.Cells(i, 1).Value), (ws4.Range("A" & i & ":BB" & i).Value)
    End If
Next i

For i = 2 To LastRow1
    ws1.Range("F" & i & ":BG" & i).Value = myDic.Item(ws1.Cells(i, 1).Value)
Next i

On Error GoTo 0

For i = 2 To b
   On Error Resume Next
    If Not myDic.Exists(sheet_2.Cells(i, 3).Value) Then
        myDic.Add (ws4.Cells(i, 3).Value), (ws4.Range("D" & i & ":BD" & i).Value)
    End If
Next i

For i = 20 To A
    ws1.Range("H" & i & ":BH" & i).Value = myDic.Item(ws1.Cells(i, 1).Value)
    ws1.Cells(i, 7).Value = ws1.Cells(i, 1).Value
Next i

On Error GoTo 0

'相手ファイル閉じる
wb4.Close savechanges:=False
Set myDic = Nothing
Set wb4 = Nothing
Set ws4 = Nothing

'アドバンスフィルタ
ws1.Activate
ws1.Range("F1").AutoFilter

'スピードUP解除
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "完了"
End Sub