Обьединение листов разных книг.

[Viktorkv]

Доброго времени суток.)
У меня проблема следующая. Необходимо суммировать данные 5 листов, расположенные в 5 книгах. Количество суммируемых книг может варьироваться от 2 и до 100.
Т.е. суммировать нужно все книги, расположенные в определенной папке, которую задаем при запуске макроса.
Работаю в 2003 офисе
Плиз, подскажите макрос.
Всем откликнувшимся огромная благодарность, выручайте)

[alex77755]

И что таблицы во всех книгах одинаковые?

[Viktorkv]

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

И что таблицы во всех книгах одинаковые?

Да, одинаковые, разное лишь наполнение

[alex77755]

Тогда сделать книгу "ИТОГ" с пустой таблицей и на кнопку навесить макрос типа:

Sub test()

  Dim Folder As String
  Dim wb As String
  Dim objWb As Workbook
  Dim workWb As Workbook
  Dim i As Integer
  Dim R, C
  Dim Q As Worksheet
  Dim REZ()
  Dim T()
  Application.ScreenUpdating = False
    Range("B10:AM29").Select
    Selection.ClearContents
    Range("A1:AM1").Select
 Set workWb = ActiveWorkbook  'Запоминаем активную книгу
 REZ = workWb.ActiveSheet.Range(Cells(7, 1), Cells(29, 39)).Value
  'Начинаем читать файлы из папки
  wb = Dir(workWb.Path & "\*.xls")
  While Len(wb) > 0 And wb <> "ИТОГ.xls"
    wb = workWb.Path & "\" & wb
    Set objWb = Workbooks.Open(wb)
        For Each Q In objWb.Sheets
         Q.Select
            m = Q.Range(Cells(7, 1), Cells(29, 39)).Value
            For R = 4 To 23
                For C = 2 To 39
                   REZ(R, C) = REZ(R, C) + m(R, C)
                Next C
            Next R
        Next
    objWb.Close False
    wb = Dir 'читаем следующий файл
  Wend
 workWb.ActiveSheet.Range(Cells(7, 1), Cells(29, 39)).Value = REZ
  Application.ScreenUpdating = True
 MsgBox "Ok", 64, ""
End Sub

[Viktorkv]

Спасибо за помощь, сейчас попробую.

[Viktorkv]

Файлы открывает, идет процесс, но суммирования нет

[Viktorkv]

Все правильно, табуляцию нарушил я. Можно сделать, чтобы шапка и форматирование в книге "ИТОГ" сохранились?

[Viktorkv]

И чтобы был запрос на папку, где хранятся книги для объединения.
В любом случае спасибо). Я уже два дня пытаюсь что-нить сочинить.

[alex77755]

Все правильно, табуляцию нарушил я. Можно сделать, чтобы шапка и форматирование в книге "ИТОГ" сохранились?

??
А разве они не сохраняются? У меня только нулевые значения показываются.
Поставил в параметрах не показывать.

И чтобы был запрос на папку, где хранятся книги для объединения.

Option Explicit
Sub test()

  Dim Folder As String
  Dim wb As String
  Dim objWb As Workbook
  Dim workWb As Workbook
'  Dim i As Integer
  Dim R, C
  Dim Q As Worksheet
  Dim REZ()
  Dim M()
  Application.ScreenUpdating = False
    Range("B10:AM29").Select
    Selection.ClearContents
    Range("A1:AM1").Select
 Set workWb = ActiveWorkbook  'Запоминаем активную книгу
 REZ = workWb.ActiveSheet.Range(Cells(7, 1), Cells(29, 39)).Value
 
   'Показываем диалог выбора папки
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Выберите папку, файлы в которой нужно обработать"
    .ButtonName = "Выбрать"
    .AllowMultiSelect = False
    If .Show Then Folder = .SelectedItems(1) Else Exit Sub
  End With
  'Начинаем читать файлы из папки
  wb = Dir(Folder & Application.PathSeparator & "*.xls")
  While Len(wb) > 0 And wb <> "ИТОГ.xls"
   wb = Folder & Application.PathSeparator & wb
    Set objWb = Workbooks.Open(wb)
        For Each Q In objWb.Sheets
         Q.Select
            M = Q.Range(Cells(7, 1), Cells(29, 39)).Value
            For R = 4 To 23
                For C = 2 To 39
                   REZ(R, C) = REZ(R, C) + M(R, C)
                Next C
            Next R
        Next
    objWb.Close False
    wb = Dir 'читаем следующий файл
  Wend
 workWb.ActiveSheet.Range(Cells(7, 1), Cells(29, 39)).Value = REZ
  Application.ScreenUpdating = True
  MsgBox "Ok", 64, ""
End Sub

[Viktorkv]

И последняя просьба) Скорее всего таблицы могут быть не везде одинаковые. Суммирование должно быть по строчкам 8-12 16 20 24...100.