Option Explicit
Sub フォルダ内エクセルファイル一括オープン()
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim wb As Workbook, cnt As Long, wind As Window
    Dim myFolder As Folder, myFile As File
    Set myFolder = FSO.GetFolder(ThisWorkbook.Path)
    On Error GoTo myError
    '各ファイルの拡張子を確認してエクセルファイルを判別
    For Each myFile In myFolder.Files
        If myFile.Path Like "*.xls*" Then
            cnt = 0
            For Each wb In Workbooks
                cnt = cnt + 1
                '指定のファイルが既に開いていた場合
                If myFile.Name = wb.Name Then
                    'このブックの場合は何もしない
                    If wb.Name = ThisWorkbook.Name Then
                        Exit For
                    'このブック以外の場合
                    Else
                        MsgBox myFile.Path & "は既に開いています", vbInformation
                        Exit For
                    End If
                '最後のファイルまで確認してファイル名が"~$*"でなければブックを開く
                ElseIf (cnt = Workbooks.Count) And (Not myFile.Name Like "~$*") Then
                    Workbooks.Open myFile
                    Exit For
                End If
            Next
        End If
    Next
    '各ウインドウが最大化されていなければ最大化する
    For Each wind In Windows
        With Application
            If Not .WindowState = xlMaximized Then .WindowState = xlMaximized
        End With
    Next
    Set myFolder = Nothing
    Set myFile = Nothing
    ThisWorkbook.Close
    Exit Sub
myError:
    Debug.Print Err.Number & vbCrLf & Err.Description
    Resume Next
End Sub

Option Explicit
Sub sample()
  Dim V4 As String
  Dim V5 As Object
  Dim V6 As Object
  Dim LastRow As Long
  Dim i As Long
  Dim key As String
  ' 画面更新を一時停止
  Application.ScreenUpdating = False
  ' 検索用の辞書
  Set V5 = CreateObject(“Scripting.Dictionary”)
  Set V6 = CreateObject(“Scripting.Dictionary”)

  ' 4列目の最終行を取得
  LastRow = Sheet(2).Cells(Rows.Count,4).End(xlUp).Row
  ' 検索用辞書を作成
  For i = 1 To LastRow
    V4 = Sheet(2).Cells(i,4)
    If V4 <> "" Then
      V5.Add V4, Sheet(2).Cells(i,5).Value
      V6.Add V4, Sheet(2).Cells(i,6).Value
    End If
  Next

  ' Sheet(1)の最終行を取得
  LastRow = Sheet(1).Cells(Rows.Count,1).End(xlUp).Row
  For i = 1 To LastRow
    key = Sheets(1).Cells(i, 5).Value
    If V5.Exists(key) Then '辞書に検索語が存在するか確認
      Sheets(1).Cells(i, 6).Value = V5.Item(key)
      Sheets(1).Cells(i, 7).Value = V6.Item(key)
    End If
  Next
  ' 画面更新を再開
  Application.ScreenUpdating = True
end Sub