【エクセル・マクロ・VBA】インポート＋マッチング（突合）

＜作業概要＞

インポートする基のファイルを開く（基ファイルのシート；ws1）
１つめにインポートするエクセルファイルをインポート（基シートに貼付け）
２つめにエクセルファイルを開き、ディクショナリで1列目をキーに2列目をアイテムに登録
基シートの1列目のセルと2つ目のエクセルファイルの1列目のセルをマッチングして、マッチしたものを基シートに転記

Sub 別ファイルをインポートしてマッチング()

'このファイル
Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
    Set ws1 = wb1.ActiveSheet
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

'1つ目のインポートするファイル開く
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
    MsgBox "File未選択 "
End
End If

ws1.Activate

'ファイルをインポート
ws1.Cells.Clear
ws2.Range("A1").CurrentRegion.Copy Destination:=ws1.Range("A1")

'コピーモード解除
Application.CutCopyMode = False

'２つ目のインポートファイル開く
'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
End If

'突合処理
Dim myDic As Object, myKey
Dim c, myVal
Dim i As Long
Dim LastColumn1 As Long
LastColumn1 = ws1.Cells(1, 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, 1).Value) Then
         myDic.Add (ws3.Cells(i, 1).Value), (ws3.Cells(i, 2).Value)
      End If
 Next i
   On Error GoTo 0
End With

With ws1
 For i = 2 To LastRow1 + 1
      If myDic.Exists(ws1.Cells(i, 1).Value) Then
         ws1.Cells(i, LastColumn1).Value = myDic.Item(ws3.Cells(i, 1).Value)
      End If
 Next i

Application.StatusBar = i - 2 & "/" & LastRow1 & " を完了"
End With

ws1.Cells(1, LastColumn1).Value = "新規追加"

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

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

ws1.Range("A1").Select

MsgBox "完了"
End Sub

＜作業詳細＞

インポートする基のファイルを開く（基ファイルのシート；ws1）
基ファイルをインポートするシートはsheet1を指定
ダイアログを開き、１つ目のエクセルファイルを選択（1つ目のインポートファイルのシート；ws2）
一つ目のインポートファイル（ws2）のA1セルを含む表をコピーして基ファイル（ws1）のA1に貼付け
ダイアログを開き、2つ目のエクセルファイルを選択（2つ目のインポートファイルのシート；ws3）
2つ目のエクセルファイル（ws3）の1列目のセルをキーに2列目のセルをアイテムにディクショナリで登録
基ファイルの1列目のセルと2つ目のインポートファイルの１列目のセルが一致した場合、アイテムを最終列に転記
2つ目のファイルを閉じる
基ファイルのA1セルを選択

解説

5行目：ファイルを指定する場合
Workbooks(“Book1.xls“)　＊赤字箇所にファイル名を表記
参考）Set ws =ThisWorkbook.ActiveSheet　／　Set ws = ThisWorkbook.Worksheets(1)
38行目：項目名（1行目）を除くセルを削除する場合
ws1.Range(“A1”).CurrentRegion.Offset(1.1).Clear
39行目：参考）別の範囲指定方法
ws1.Cells(1, 1) = ws2.Range(“A2:Y” & Cells(Rows.Count, “B”).End(xlUp).Row)
40行目：参考）削除したい列がある場合　Columns(“A:B”).Delete
　　　　参考）別シートから項目名をコピーする場合 wb1.Sheets(“項目”).Rows(1).Copy ws1.Rows(1)
45行目：列の表示形式を文字列へ変換したい場合、以下を挿入

'取り込んだファイルのキー列の表示形式を文字列へ変換
Dim LastRow1 As Long
LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
ws1.Range("A2:A" & LastRow1).Select
Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat)
Selection.NumberFormatLocal = "@"

76行目：列の表示形式を文字列へ変換したい場合、以下を挿入

'取り込んだファイルのキー列の表示形式を文字列へ変換
ws3.Range("A2:A" & LastRow1).Select  '最終行確認
Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, FieldInfo:=Array(1, xlTextFormat)  'おかしい
Selection.NumberFormatLocal = "@"