【マクロ・VBA】複数ファイルを連続でインポート対応：エクセルファイルをインポートする時、ダイアログでキーとアイテムを選択した後、Dictionaryで最終列にマッチング（突合）する

Sub キー項目選択インポート表示形式変更最終列に突合()

Dim Result10 As Long
Result10 = MsgBox("ファイルをインポートしますか？", vbYesNo + vbExclamation)
    
If Result10 = vbYes Then
    
    '[はい]がクリックされたときの処理
    Worksheets.Add(After:=ActiveSheet).Name = "Import" & "_" & VBA.Format(Now(), "h時mm分ss秒")

    'このファイル
    Dim wb1 As Workbook
      Set wb1 = ThisWorkbook
    Dim ws1 As Worksheet
      Set ws1 = wb1.ActiveSheet
 
    'インポートファイル
    Dim FName As String
    MsgBox "「インポートファイル」選択"
    FName = Application.GetOpenFilename("Microsoft Excelブック,*.xls*")

    If FName <> "False" Then
        Dim wb2 As Workbook
          Set wb2 = Workbooks.Open(FName)
        Dim ws2 As Worksheet
          Set ws2 = wb2.Worksheets(1)
        Dim LastRow2 As Long
          LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
        Dim LastCol2 As Long
          LastCol2 = ws2.Cells(1, Columns.Count).End(xlToLeft).Column
    Else
        GoTo Skip
    End If
Else
    GoTo Skip
End If
       
ws1.Activate

'インポート
ws2.Range("A1").CurrentRegion.Copy Destination:=ws1.Range("A1")
             
'インポートファイル閉じる
wb2.Close savechanges:=False
Application.CutCopyMode = False

Skip:
                               
'変数を削除
Set wb2 = Nothing
Set ws2 = Nothing
Set Rng = Nothing

YES_TASK500:

ws1.Activate

'Dim FName As String
MsgBox "「インポートファイル」選択"
FName = Application.GetOpenFilename("Microsoft Excelブック,*.xls*")

If FName <> "False" Then
    Dim wb3 As Workbook
    Dim ws3 As Worksheet
    
    Set wb3 = Workbooks.Open(FName)
    Set ws3 = wb3.Worksheets(1)
    Dim LastRow3 As Long
        LastRow3 = ws3.Cells(Rows.Count, 1).End(xlUp).Row
    Dim LastCol3 As Long
        LastCol3 = ws3.Cells(1, Columns.Count).End(xlToLeft).Column
Else
    MsgBox "File未選択 "
End If

'表示形式を変更しますか？
Dim buf As VbMsgBoxResult
buf = MsgBox("表示形式を変更しますか？する場合「はい」／しない場合は「いいえ」", vbYesNo)

If buf = vbYes Then
    GoTo YES_TASK1
Else
    GoTo NO_TASK1
End If

YES_TASK1:
      
'表示形式を変換する列を選択
Dim rng2 As Range
On Error Resume Next
   Set rng2 = Application.InputBox(prompt:="表示形式を変更する列を含むセルを選択してください", Type:=8)
On Error GoTo 0

If rng2 Is Nothing Then
End If

rng2.EntireColumn.Select
Selection.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat)

Selection.NumberFormatLocal = "@"


NO_TASK1:

'キーを選択
Dim rng10 As Range
On Error Resume Next
Set rng10 = Application.InputBox(prompt:="キーにするセルを選択", Type:=8)
    rng10_no = rng10.Column
On Error GoTo 0

If rng10 Is Nothing Then
End If
    
'とる列を選択
Dim rng20 As Range
On Error Resume Next
   Set rng20 = Application.InputBox(prompt:="とるセルを選択", Type:=8)
rng20_no = rng20.Column
On Error GoTo 0

If rng20 Is Nothing Then
End If
    
'ファイル突合
 Dim myDic As Object
'Dim C, myVal
 Dim i As Long
 Dim LastColumn1 As Long
     LastColumn1 = ws1.Cells(2, Columns.Count).End(xlToLeft).Column + 1       '.Offset(-1, 0)

     Set myDic = CreateObject("Scripting.Dictionary")

    '相手ファイル
    With ws3
        For i = 2 To LastRow3 + 1
            DoEvents
            On Error Resume Next
            If Not myDic.Exists(ws3.Cells(i, rng10_no).Value) Then
                  myDic.Add (ws3.Cells(i, rng10_no).Value), (ws3.Cells(i, rng20_no).Value)
            End If
            Application.StatusBar = i - 1 & "/" & LastRow3 & " 完了"
        Next i
            On Error GoTo 0
    End With

'ウィンドウの切り替え
Windows(2).Activate

'表示形式を変更しますか？
Dim buf2 As VbMsgBoxResult
buf2 = MsgBox("表示形式を変更しますか？する場合「はい」／しない場合は「いいえ」", vbYesNo)

If buf2 = vbYes Then
    GoTo YES_TASK2
Else
    GoTo NO_TASK2
End If

YES_TASK2:
      
'表示形式を変換する列を選択
'Dim rng2 As Range
On Error Resume Next
   Set rng2 = Application.InputBox(prompt:="表示形式を変更する列を含むセルを選択してください", Type:=8)
On Error GoTo 0

If rng2 Is Nothing Then
End If

rng2.EntireColumn.Select
Selection.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat)

Selection.NumberFormatLocal = "@"

NO_TASK2:

 'キーを選択
    Dim rng30 As Range
    On Error Resume Next
        Set rng30 = Application.InputBox(prompt:="キーにするセルを選択", Type:=8)
        rng30_no = rng30.Column
    On Error GoTo 0

    If rng30 Is Nothing Then
    End If
    
    Dim LastRow1 As Long
      LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Dim LastCol1 As Long
       LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

    'このファイル
    With ws1
        For i = 2 To LastRow1 + 1 'コピー先（貼り付け先）最終列プラス１をrngにセット
        DoEvents
        On Error Resume Next
        'ws1.Cells(i, LastColumn1).Value = 1
            If myDic.Exists(ws1.Cells(i, rng30_no).Value) Then
                ws1.Cells(i, LastColumn1).Value = myDic.Item(ws3.Cells(i, rng10_no).Value)
            End If
            Application.StatusBar = i - 2 & "/" & LastRow1 & " 完了"
        Next i
            On Error GoTo 0
    End With

'相手ファイル閉じる
wb3.Close savechanges:=False

myDic.RemoveAll
Set myDic = Nothing
Set wb3 = Nothing
Set ws3 = Nothing
'LastRow3 = Nothing
Set rng2 = Nothing

'継続？
ret = MsgBox("突合ファイルを追加しますか？追加は「はい」／終了の場合は「いいえ」", vbYesNo)

If ret = vbYes Then
    GoTo YES_TASK500
Else
    GoTo NO_TASK3
End If

NO_TASK3:

MsgBox "完了"
End Sub