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

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
Private aValue As Variant

Sub Сбора_данных()
    Dim aFiles As Variant
    aFiles = ShowFileDialog()
    If IsEmpty(aFiles) Then Exit Sub
    
    aValue = Empty
    CloseEmptyWb
    
    Dim vFile As Variant
    For Each vFile In aFiles
        GetFromFile vFile
    Next
    
    If IsEmpty(aValue) Then Exit Sub
    ValueOnly
    
    OutputArray
End Sub

Private Sub ValueOnly()
    Dim yv As Long
    For yv = UBound(aValue) To LBound(aValue) Step -1
        If Not IsEmpty(aValue(yv)) Then Exit For
    Next
    If yv >= LBound(aValue) Then
        If yv < UBound(aValue) Then
            ReDim Preserve aValue(LBound(aValue) To yv)
        End If
    End If
End Sub

Private Sub OutputArray()
    Dim arr As Variant
    arr = ResizeArray()
        
    arr = CDblArray(arr)
        
    Dim rr As Range
    Set rr = Workbooks.Add(1).Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
    rr.Value = arr
    rr.Columns(2).EntireColumn.AutoFit
End Sub

Private Function CDblArray(arr As Variant) As Variant
    Dim ya As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = 1 To UBound(arr, 1)
            If IsNumeric(arr(ya, xa)) Then
                arr(ya, xa) = CDbl(arr(ya, xa))
            End If
        Next
    Next
    CDblArray = arr
End Function

Private Function ResizeArray() As Variant
    Dim xa As Long, ya As Long, arr As Variant
    ReDim arr(1 To UBound(aValue), 1 To UBound(aValue(1)) - LBound(aValue(1)) + 1)
    
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            arr(ya, xa) = aValue(ya)(xa - 1)
        Next
    Next
    ResizeArray = arr
End Function

Private Sub GetFromFile(ByVal sFull As String)
    If Dir(sFull) = "" Then Exit Sub
    
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFull, False, True)
    
    GetFromWorkbook wb
    
    If wb.ReadOnly Then wb.Close False
End Sub

Private Sub GetFromWorkbook(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Sheets
        If sh.UsedRange.Cells.CountLarge > 1 Then
            GetFromUsedRange sh.UsedRange.Value
        End If
    Next
End Sub

Private Sub GetFromUsedRange(arr As Variant)
    Dim ya As Long, yb As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = 1 To UBound(arr, 1)
            If arr(ya, xa) = "1. Начислено" Then
                For yb = ya + 1 To UBound(arr, 1)
                    If arr(yb, xa) = "Всего начислено" Then
                        Exit For
                    End If
                Next
                If yb <= UBound(arr, 1) Then
                    GetFromSubArray arr, ya + 1, yb - 1
                    ya = yb
                End If
            End If
        Next
    Next
    
End Sub

Private Sub GetFromSubArray(arr As Variant, yBeg As Long, yEnd As Long)
    If yBeg - 3 <= 0 Then Exit Sub
    Dim hrr As Variant, xrr As Variant
    hrr = Array("Вид", "Период", "Сумма")
    ReDim xrr(LBound(hrr) To UBound(hrr))
    
    
    Dim xa As Long, xi As Long
    For xa = 1 To UBound(arr, 2)
        For xi = LBound(hrr) To UBound(hrr)
            If arr(yBeg - 3, xa) = hrr(xi) Then
                xrr(xi) = xa
                If xi = UBound(hrr) Then Exit For
            End If
        Next
        If xi = UBound(hrr) Then Exit For
    Next
    For xi = LBound(xrr) To UBound(xrr)
        If IsEmpty(xrr(xi)) Then Exit Sub
    Next
    
    Dim ya As Long, vrr As Variant
    ReDim vrr(LBound(hrr) To UBound(hrr))
    For ya = yBeg To yEnd
        For xi = LBound(xrr) To UBound(xrr)
            xa = xrr(xi)
            vrr(xi) = arr(ya, xa)
        Next
        AddValueArray vrr
    Next
End Sub

Private Sub AddValueArray(vrr As Variant)
    If IsEmpty(aValue) Then
        ReDim aValue(1 To 1)
    End If
    If Not IsEmpty(aValue(UBound(aValue))) Then
        ReDim Preserve aValue(1 To 2 * UBound(aValue))
    End If
    Dim yv As Long
    For yv = UBound(aValue) To LBound(aValue) Step -1
        If Not IsEmpty(aValue(yv)) Then Exit For
    Next
    yv = yv + 1
    aValue(yv) = vrr
End Sub

Private Function ShowFileDialog() As Variant
    'ShowFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    Dim rInitialFileName As Range
    On Error Resume Next
    Set rInitialFileName = ThisWorkbook.Sheets(1).Cells(1, 1)
    On Error GoTo 0
    
    Dim sInitialFileName As String
    sInitialFileName = rInitialFileName.Value
    If Left(sInitialFileName, 2) = ".\" Then
        sInitialFileName = Mid(sInitialFileName, 2)
        sInitialFileName = ThisWorkbook.Path & sInitialFileName
    End If
    
    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)
                        If Not rInitialFileName Is Nothing Then
                            sInitialFileName = .SelectedItems(lf)
                            sInitialFileName = Replace(sInitialFileName, ThisWorkbook.Path, ".")
                            rInitialFileName.Value = sInitialFileName
                        End If
                    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

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

Private Sub CommandButton1_Click()

If (TextBox1.Text = "") Or (ComboBox1.Text = "") Or (ComboBox2.Text = "") Or (ComboBox3.Text = "") Or (TextBox4.Text = "") Then
MsgBox "Обязательные поля формы не заполнены!", vbCritical

Else
'заполняем столбцы таблицы
Dim rangeToSearch As Range
Dim mtb, mtbcopy As ListObject
Dim short_name
Dim msg_success As String
Dim max_rows, added_index, i As Long

short_name = ComboBox1.Text
Set rangeToSearch = ThisWorkbook.Worksheets("Data").Range("SERVICES_TABLE[Услуга]")

Set mtb = ThisWorkbook.Worksheets("Data").ListObjects("MAIN_TABLE")
Set mtbcopy = ThisWorkbook.Worksheets("Таблица").ListObjects("COPY_TABLE")

Dim ComboBox3_Text As String
ComboBox3_Text = ComboBox3.Text
mtb.ListRows.Add
ComboBox3.Text = ComboBox3_Text
mtb.Range((mtb.ListRows.Count + 1), 1).Value = CDate(TextBox1.Value)
mtb.Range((mtb.ListRows.Count + 1), 2).Value = ComboBox3.Text
mtb.Range((mtb.ListRows.Count + 1), 3).Value = ComboBox2.Text
mtb.Range((mtb.ListRows.Count + 1), 4).Value = ComboBox1.Text
'заполняем столбцы 5 и 6

short_name = ComboBox3.Text
Set fCell = rangeToSearch.Find(short_name)
mtb.Range((mtb.ListRows.Count + 1), 5).Value = Worksheets("Data").Cells(fCell.Row, 36).Value
mtb.Range((mtb.ListRows.Count + 1), 2).Value = ComboBox3.Text

If OptionButton1 Then
mtb.Range((mtb.ListRows.Count + 1), 6).Value = "ФЛ"
Else: mtb.Range((mtb.ListRows.Count + 1), 6).Value = "ЮЛ"
End If

If OptionButton3 Then
mtb.Range((mtb.ListRows.Count + 1), 7).Value = TextBox4.Value
Else: mtb.Range((mtb.ListRows.Count + 1), 8).Value = TextBox4.Value
End If

mtb.Range((mtb.ListRows.Count + 1), 9).Value = TextBox2.Value
mtb.Range((mtb.ListRows.Count + 1), 10).Value = TextBox3.Value
mtb.Range((mtb.ListRows.Count + 1), 11).Value = ComboBox4.Value

'копируем последние 50 строк в таблицу, которую увидит специалист

max_rows = 50
If mtb.ListRows.Count > max_rows Then
added_index = mtb.ListRows.Count - max_rows
Else: added_index = 0
End If

For i = 1 To max_rows Step 1
mtbcopy.Range(i + 1, 1).Value = mtb.Range(i + added_index + 1, 1)
mtbcopy.Range(i + 1, 2).Value = mtb.Range(i + added_index + 1, 2)
mtbcopy.Range(i + 1, 3).Value = mtb.Range(i + added_index + 1, 3)
mtbcopy.Range(i + 1, 4).Value = mtb.Range(i + added_index + 1, 7)
mtbcopy.Range(i + 1, 5).Value = mtb.Range(i + added_index + 1, 8)
mtbcopy.Range(i + 1, 6).Value = mtb.Range(i + added_index + 1, 9)
mtbcopy.Range(i + 1, 7).Value = mtb.Range(i + added_index + 1, 10)
mtbcopy.Range(i + 1, 8).Value = mtb.Range(i + added_index + 1, 11)

Next

msg_success = "Данные внесены успешно" & vbCrLf & TextBox1.Value & "  Услуга " & ComboBox3.Text & vbCrLf & "Заявления(консультации):  " & TextBox4.Text & vbCrLf & "Специалист:  " & ComboBox4.Text
MsgBox msg_success, vbOKOnly + vbInformation
End If

End Sub