Option Explicit
Private dic As Object

Sub Знает_весь_район_тигр()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    Set dic = GetDic()
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim vFile As Variant
    For Each vFile In aFiles
        JobFile vFile
    Next
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetDic() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim cl As Range
    For Each cl In ActiveSheet.UsedRange.Columns(3).Cells
        Select Case cl.Value
        Case "Модель", ""
        Case Else
            Set dic.Item(cl.Value) = cl
        End Select
    Next
    Set GetDic = dic
End Function

Private Sub JobFile(ByVal sFull As String)
    Dim needClose As Boolean
    Dim wb As Workbook
    Set wb = GetWb(sFull, needClose)
    If wb Is Nothing Then Exit Sub
    JobSheet wb.Sheets(1)
    
    If needClose Then wb.Close False
End Sub

Private Sub JobSheet(sh As Worksheet)
    Dim cl As Range
    For Each cl In sh.UsedRange.Columns(3).Cells
        If dic.Exists(cl.Value) Then
            cl.EntireRow.Copy dic.Item(cl.Value).EntireRow
        End If
    Next
End Sub

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
    On Error GoTo 0

    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        If Not rInitialFileName Is Nothing Then .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(CreateObject("Scripting.FileSystemObject").GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String, needClose As Boolean) As Workbook
    needClose = False
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull)
        needClose = True
    End If
    
    Set GetWb = wb
End Function

'aFiles = ShowFileDialog()
redim aFiles(1 to 2)
aFiles(1) = "C:\temp\1.xlsx"
aFiles(2) = "C:\temp\2.xlsx"

Option Explicit
Private dic As Object
Private aTarget As Variant

Sub Знает_весь_район_большой_тигр()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
        
    Dim rTarget As Variant
    Set rTarget = ActiveSheet.UsedRange
    aTarget = rTarget.Value
    
    Set dic = GetDic()
    
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim vFile As Variant
    For Each vFile In aFiles
        JobFile vFile
    Next
    
    rTarget.Value = aTarget
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetDic() As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 2 To UBound(aTarget, 1)
        Select Case aTarget(ya, 3)
        Case "Модель", ""
        Case Else
            dic.Item(aTarget(ya, 3)) = ya
        End Select
    Next
    Set GetDic = dic
End Function

Private Sub JobFile(ByVal sFull As String)
    Dim needClose As Boolean
    Dim wb As Workbook
    Set wb = GetWb(sFull, needClose)
    If wb Is Nothing Then Exit Sub
    JobSheet wb.Sheets(1)
    
    If needClose Then wb.Close False
End Sub

Private Sub JobSheet(sh As Worksheet)
'    Dim cl As Range
'    For Each cl In sh.UsedRange.Columns(3).Cells
    Dim aFrom As Variant
    aFrom = sh.UsedRange.Value

    Dim yf As Long
    Dim yt As Long
    Dim xt As Long
    For yf = 2 To UBound(aFrom, 2)
        If dic.Exists(aFrom(yf, 3)) Then
            yt = dic(aFrom(yf, 3))
            For xt = 1 To UBound(aTarget, 2)
                aTarget(yt, xt) = aFrom(yf, xt)
            Next
            'cl.EntireRow.Copy dic.Item(cl.Value).EntireRow
        End If
    Next
End Sub

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Names("Файл").RefersToRange
    On Error GoTo 0

    Dim oFD As FileDialog
    Dim x, lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        If Not rInitialFileName Is Nothing Then .InitialFileName = rInitialFileName.Value
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            If Left(CreateObject("Scripting.FileSystemObject").GetFileName(.SelectedItems(lf)), 2) <> "~$" Then
                If IsEmpty(arr) Then
                    ReDim arr(1 To 1)
                    If Not rInitialFileName Is Nothing Then rInitialFileName.Value = .SelectedItems(lf)
                Else
                    ReDim Preserve arr(1 To UBound(arr) + 1)
                End If
                arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Private Function GetWb(ByVal sFull As String, needClose As Boolean) As Workbook
    needClose = False
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FileExists(sFull) Then Exit Function
    Dim sName As String
    sName = fso.GetFileName(sFull)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(sName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        If LCase(wb.FullName) <> LCase(sFull) Then
            wb.Close False
            Set wb = Nothing
        End If
    End If
    If wb Is Nothing Then
        Set wb = Workbooks.Open(sFull)
        needClose = True
    End If
    
    Set GetWb = wb
End Function