Обработка таблиц

[Zloydog]

Такая ситуация- в папке содержатся документы excel от рганизаций(документ 1,2,3,4 итд) (таблицы у них все одиннаковые) в каждом документы примерно по 8 листов. В каждом листе столбцы с разной информацией (B,C,D,E итд)
Нужно сделать так,чтобы столбцы сводились в один документ из кадого документа (1,2,3,4 итд) - сумма по каждому столбцу.
Возможно ли? и примерно как?

[RomaS]

Держи решение.
Во вложении главный файл и несколько тестовых для перебора

Код: Выделить всё

Sub Кнопка2_Щелкнуть()
 ' Create by Romas654
 ' макрос в исходной папке перебирает все файлы xls, а в них все листы
 ' и помещает все значения в соответствующие столбцы в этой книге (А в А, В в В и т.д.)
 
    Dim Wb As Workbook, AllDoc As Integer
    Dim row1 As Integer, col1 As Integer
    Dim MaxSheetsColumn As Byte
    Dim ArrAllRows() As Variant
    Dim MaxRowsInArr As Integer
    Dim ResultSheetsName As String
    MaxRowsInArr = 0
    
    ResultSheetsName = "Результат" ' название листа результатов
    MaxSheetsColumn = 3 ' сколько столбцов обрабатывать
    
    ' массив для записи № строк последних заполненных ячеек
    ReDim ArrAllRows(MaxSheetsColumn, 1)
    
    ThisWorkbook.Sheets(ResultSheetsName).Cells.ClearContents ' очистка листа результатов
        
    Application.ScreenUpdating = False
    PathFold = ThisWorkbook.Path & Application.PathSeparator
    NameFileM = Dir(PathFold & "*.XLS", vbNormal + vbReadOnly)
   
    Do While NameFileM <> ""
        If NameFileM <> ThisWorkbook.Name Then
        Set Wb = Workbooks.Open(Filename:=PathFold & NameFileM) ' открываем очередной xls в папке
        On Error Resume Next
        
        With Wb
            For Each Sh In .Worksheets ' перебираем все листы
                With Sh
                
                ' перебор данных: всё из А в А, из В в В и т.д.
                For col1 = 1 To MaxSheetsColumn
                row1 = 1
                    Do While .Cells(row1, col1).Value <> "" ' пока есть заполненные
                    'MsgBox .Cells(row1, col1).Value
                    ThisWorkbook.Sheets(ResultSheetsName).Cells(ArrAllRows(col1, 0) + row1, col1).Value = .Cells(row1, col1).Value
                    ArrAllRows(col1, 1) = ArrAllRows(col1, 1) + .Cells(row1, col1).Value
                    row1 = row1 + 1
                    Loop
                    
                    ' последняя заполненная ячейка в соответствующем столбце
                    ArrAllRows(col1, 0) = ArrAllRows(col1, 0) + row1 - 1
                Next
                End With
            Next
        AllDoc = AllDoc + 1
        
        End With
        Wb.Close
        End If
        NameFileM = Dir ' следующий файл
    Loop
    
    ' итоговая сумма
    For h = 1 To MaxSheetsColumn ' макс значение в массиве перебором
    If ArrAllRows(h, 0) > MaxRowsInArr Then MaxRowsInArr = ArrAllRows(h, 0)
    Next
    ' суммирование
    For j = 1 To MaxSheetsColumn
    ThisWorkbook.Sheets(ResultSheetsName).Cells(MaxRowsInArr + 2, j).Value = ArrAllRows(j, 1)
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово! Обработано: " & AllDoc & " файл(ов)", vbInformation, ""
    ThisWorkbook.Sheets(ResultSheetsName).Activate
End Sub