Option Explicit
'1023
Private Const sInitialFileName = "E:\Сервер\Сервер 1\Сервер 2\Сервер 3\Сервер 4\РАБОЧИЕ\Журнал выездов\"
Private Const sheetNames = "Фрукты;Овощи"
   
Sub Копировать_по_журналам()
    Dim wbSource As Workbook, wbTarget As Workbook, c As Range, arrWB(), w As Variant, sheetName As Variant, shSource As Worksheet, shTarget As Worksheet, rTarget As Range, iTarget As Long
    arrWB = ShowFileDialog()
     
    Set wbTarget = ActiveWorkbook
    With Application
       .EnableEvents = False
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .Visible = False
             
        For Each w In arrWB
            Set wbSource = Workbooks.Open(w)  ' Этот метод копирует данные в книги находящиеся по пути с главной
            For Each sheetName In Split(sheetNames, ";")
                On Error Resume Next
                Set shSource = wbSource.Worksheets(sheetName)
                Set shTarget = wbTarget.Worksheets(sheetName)
                On Error GoTo 0
                If Not shSource Is Nothing Then
                    If shTarget Is Nothing Then
                        For iTarget = (wbTarget.Worksheets.Count) To 1 Step -1
                            If wbTarget.Worksheets(iTarget).Visible = xlSheetVisible Then Exit For
                        Next
                        shSource.Copy After:=wbTarget.Worksheets(iTarget)
                        Set shTarget = wbTarget.Worksheets(sheetName)
                    End If
                
                    shSource.Cells.Copy shTarget.Cells 'копируем все данные с активного листа
                    On Error Resume Next
                    Set rTarget = wbTarget.Worksheets(sheetName).Cells.SpecialCells(xlCellTypeFormulas, 23)
                    On Error GoTo 0
                    If Not rTarget Is Nothing Then
                        For Each c In rTarget.Cells
                            c.FormulaLocal = Replace(c.FormulaLocal, "[" & wbSource.Name & "]", "")
                        Next c
                        Set rTarget = Nothing
                    End If
                    Set shSource = Nothing
                End If
                Set shTarget = Nothing
            Next
            wbSource.Close False
        Next w
             
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .Visible = True
    End With
    MsgBox "Готово"
End Sub
   
Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
       
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
       
    Dim oFD As FileDialog
    Dim 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(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function

Option Explicit
'1426
Private Const sInitialFileName = "E:\Сервер\Сервер 1\Сервер 2\Сервер 3\Сервер 4\РАБОЧИЕ\Журнал выездов\"
Private Const sheetNames = "Фрукты;Овощи"
    
Sub Копировать_по_журналам()
    Dim wbSource As Workbook, wbTarget As Workbook, c As Range, arrWB(), w As Variant, sheetName As Variant, shSource As Worksheet, shTarget As Worksheet, rTarget As Range, iTarget As Long
    arrWB = ShowFileDialog()
      
    Set wbTarget = ActiveWorkbook
    With Application
       .EnableEvents = False
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .Visible = False
              
        For Each w In arrWB
            Set wbSource = Workbooks.Open(w)  ' Этот метод копирует данные в книги находящиеся по пути с главной
            
            For Each sheetName In Split(sheetNames, ";")
                On Error Resume Next
                Set shSource = wbSource.Worksheets(sheetName)
                Set shTarget = wbTarget.Worksheets(sheetName)
                On Error GoTo 0
                If Not shSource Is Nothing Then
                    If shTarget Is Nothing Then
                        For iTarget = (wbTarget.Worksheets.Count) To 1 Step -1
                            If wbTarget.Worksheets(iTarget).Visible = xlSheetVisible Then Exit For
                        Next
                        shSource.Copy After:=wbTarget.Worksheets(iTarget)
                        Set shTarget = wbTarget.Worksheets(sheetName)
                    End If
                 
                    shSource.Cells.Copy shTarget.Cells 'копируем все данные с активного листа
                    
                    On Error Resume Next
                    wbTarget.ChangeLink Name:=shSource.Name, NewName:=wbTarget.Name, Type:=xlExcelLinks
                    On Error GoTo 0
                    
                    On Error Resume Next
                    Set rTarget = wbTarget.Worksheets(sheetName).Cells.SpecialCells(xlCellTypeFormulas, 23)
                    On Error GoTo 0
                    If Not rTarget Is Nothing Then
                        For Each c In rTarget.Cells
                            c.FormulaLocal = Replace(c.FormulaLocal, "[" & wbSource.Name & "]", "")
                        Next c
                        Set rTarget = Nothing
                    End If
                    Set shSource = Nothing
                End If
                Set shTarget = Nothing
            Next
            wbSource.Close False
        Next w
              
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .Visible = True
    End With
    MsgBox "Готово"
End Sub
    
Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
        
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
        
    Dim oFD As FileDialog
    Dim 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(Текстовые файлы)
        .InitialFileName = sInitialFileName
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If .Show = 0 Then Exit Function 'показывает диалог
        Dim arr As Variant, sName As String
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            sName = fso.GetFileName(.SelectedItems(lf))
            If Left(sName, 2) <> "~$" Then
                If sName <> ThisWorkbook.Name Then
                    If IsEmpty(arr) Then
                        ReDim arr(1 To 1)
                    Else
                        ReDim Preserve arr(1 To UBound(arr) + 1)
                    End If
                    arr(UBound(arr)) = .SelectedItems(lf)  'считываем полный путь к файлу
                End If
            End If
        Next
        ShowFileDialog = arr
    End With
End Function