Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос для суммирования значений из разных КНИГ адаптация
 

Уважаемые специалисты!

Имеется большое количество таблиц одинаковой структуры. Каждая таблица - отдельная книга. Все книги расположены в одной папке.  
Необходимо произвести суммирование аналогичных ячеек в отдельный файл.

На сайте я нашел похожую тему с макросом.

https://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=5169

Однако у меня отличается структура таблиц.

Можно ли адаптировать макрос под мои таблицы?

В суммирующей таблице очистку и суммирование данных нужно проводить с ячейки В4.

Кроме того, наименования таблиц (по колонке А и строке 3) связаны с суммирующей таблицей ссылками. Макрос суммирует везде, где имеются ссылки.

Можно ли ячейки с суммой 0 оставлять пустыми?

Пример прилагаю.

Заранее благодарен!

Код макроса, который нужно адаптировать.

Код
Option Explicit

Sub SummAll()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'лист для суммы в общем файле
Dim TempWb As Workbook 'по-очерёдно открываемый файл
Dim TempSht As Worksheet 'лист для суммы в по-очерёдно открываемом файле

Dim iTempFileName As String 'имя по-очерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы

Dim iCol As Long 'строка в файле
Dim iRow As Long 'столбец в файле
Dim iRowTmp As Long 'последняя заполненная строка в файле по столбцам
Dim iColTmp As Long 'последний заполненный столбец в  файле
Dim iNumFiles As Long 'количество открываемых файлов


    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        Set BazaWb = ThisWorkbook
        Set BazaSht = BazaWb.ActiveSheet
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        
            'удаляем данные перед суммированием, если нужно
            With BazaSht
                .Range(.Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(1, Columns.Count).End(xlToLeft).Column)).ClearContents
            End With
      
        'по очереди открываем файлы из папки
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                Set TempWb = .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                     iNumFiles = iNumFiles + 1
                     Set TempSht = TempWb.ActiveSheet
                     
                     'Рабочая книга не должна быть защищена паролем
                     With TempSht
                        'всего столбцов в открытом листе
                        iColTmp = .Cells(1, Columns.Count).End(xlToLeft).Column
                          
                            For iCol = 1 To iColTmp
                                'номер последней заполненой строки в столбце
                                iRowTmp = .Cells(Rows.Count, 1).End(xlUp).Row
                                
                                    For iRow = 2 To iRowTmp
                                    
                                        BazaSht.Cells(iRow, iCol).Value = BazaSht.Cells(iRow, iCol).Value + .Cells(iRow, iCol).Value
                                    
                                    Next iRow
                                    
                            Next iCol
                         
                     End With
                     TempWb.Close saveChanges:=False
                
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Данные обработаны из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub


 
Проверяйте
Скрытый текст
Изменено: Sanja - 6 Апр 2018 08:17:17
Согласие есть продукт при полном непротивлении сторон.
 
Sanja,большое спасибо!
Потестировал макрос - всё OK!
Удачи Вам!
Страницы: 1
Читают тему (гостей: 1)