Свод нескольких файлов в один

[IgorGO]

vba может справиться с любой задачей в Excel, если только задача достаточно точно описана и есть кому написать код

[Serge_Bliznykov]

Сообщение от TVkills

поэтому понравившийся пример для выбора диапазона посредством vba во втором посте (в первой его половине), попробуйте у себя его запустить, справится такая часть vba кода с задачей, как думаете?

попробовал запустить.
немного изменил под ваш формат.

Сбор данных.xlsm.rar

вроде работает:

Sub Кнопка1_Щелчок()

Dim r As Range, ccell As Range, wb As Workbook, svodwb As Workbook, awb As Workbook, s$, sExt$, i&
Dim wsSh As Worksheet, wsDataSheet As Worksheet, lastrow&
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

'MsgBox "=" & awb.FullName
On Error Resume Next
Set objFolder = objFSO.GetFolder([B1])
If Err Then
  MsgBox "Ошибочное имя каталога " & [B1]
  Exit Sub
End If

Set svodwb = Workbooks.Open([B2])
If Err Then
  MsgBox "Невозможно открыть сводный файл " & [B2]
  Exit Sub
End If

Set awb = ThisWorkbook
s = "Обработано:"
'Set r = Range("E9:E29") 'задание диапазона суммирования
'r.ClearContents

' Очистим сводный файлы
For Each wsSh In svodwb.Worksheets
              
  ' последнюю строчку ищем по столбцу A номер 1
  lastrow = wsSh.Cells(Rows.Count, 1).End(xlUp).Row
  Set r = wsSh.Range("E9:E" & lastrow) 'задание диапазона суммирования
  r.ClearContents
              
Next wsSh
                

'проход по всем файлам в папке "\files"
For Each objFile In objFolder.Files
    sExt = LCase(objFSO.GetExtensionName(objFile.Name))
    If (sExt = "xls") Or (sExt = "xlsx") Then

        If Not ((objFile.Path = awb.FullName) Or (objFile.Path = svodwb.FullName) Or (Left(objFile.Name, 2) = "~$")) Then
            Set wb = Workbooks.Open(objFile)
            If Err Then
                MsgBox ("Ошибка при открытии файла " & objFile)
                Err.Clear
            Else
                i = i + 1
                s = s & vbCr & i & "." & objFile
                
                For Each wsSh In svodwb.Worksheets
                              
                  ' последнюю строчку ищем по столбцу A номер 1
                  lastrow = wsSh.Cells(Rows.Count, 1).End(xlUp).Row
                  Set r = wsSh.Range("E9:E" & lastrow) 'задание диапазона суммирования
                  For Each ccell In r
                      ccell.Value = ccell.Value + wb.Sheets(wsSh.Name).Range(ccell.Address)
                  Next ccell
                              
                Next wsSh
                
                
                'проход по ячейкам
                '    For Each cel In r
                '   cel.Value = cel.Value + wb.Sheets("п5").Range(cel.Address)
                '   Next
                wb.Close False
            End If
        End If
    End If
Next
MsgBox s

End Sub