Консолидация данных из разных книг макрос - VBA

Узнай цену своей работы

Формулировка задачи:

Уважаемые!доброго времени суток! очень нужна Ваша помощь (с VBA даже не на Вы). Есть несколько абсолютно однотипных книг только с разными названиями (количество и названия листов в книгах совпадают), необходимо консолидировать данные следующим образом, например три книги: книга1, книга2 и книга3, в каждой соответственно лист1, лист2, лист3, нужно создать копию книги, очистить диапазон ячеек для консолидации (с этим я справилась), и консолидировать по след. принципу: в копии на листе1 консолидировать диапазон ячеек (всегда постоянный, например, B10:B20) с листа1!книги1, листа1!книги2, листа1!книги3 и т.д; на листе2 - данные B10:B20 с листа2!книги1, с листа2!книги2, листа2!книги3 и т.д. и соответственно на листе3 консолидировать B10:B20 все листы3 из всех книг, на 4-ом четвертые и т.д. по индексу не получится, ибо порядок листов может отличаться т.е. как я понимаю, берем имя листа в книге, где будет результат консолидации, ищем листы с таким же названием в книгах с данными и консолидируем (функция сумма, связь с данными - True). Количество книг и листов может быть разное. проблема организовать перебор одновременно по книгам и листам. Заранее, огромное спасибо!!!!

Решение задачи: «Консолидация данных из разных книг макрос»

textual
Листинг программы
Sub main()
    Dim WbOzenki As Workbook, WbSvod As Workbook
    Dim sh As Worksheet
    
    FileOzenki = Application.GetOpenFilename(filefilter:="Workbooks(*.xls;*.xlsx),*.xls;*.xlsx", _
                Title:="Выберите файлы с КР_оценки", MultiSelect:=True)
    
    If Not IsArray(FileOzenki) Then Exit Sub
    Application.ScreenUpdating = False
    
    For j = 1 To UBound(FileOzenki)
        Workbooks.Open (FileOzenki(j))
        Set WbOzenki = ActiveWorkbook
        If j = 1 Then
            WbOzenki.SaveAs "КР_сводная"
            Set WbSvod = ActiveWorkbook
            GoTo SledFile
        End If
        WbSvod.Activate
        With WbSvod
            For i = 1 To .Sheets.Count
                .Sheets(i).Activate
                For Each sh In WbOzenki.Sheets
                    If sh.Name = .Sheets(i).Name Then
                        sh.Range("B3:B7").Copy
                        .Sheets(i).Range("B3:B7").PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
                    End If
                Next
SledSheet:
            Next i
        End With
        WbOzenki.Close False
SledFile:
    Next j
    WbSvod.Save
    Application.ScreenUpdating = True
End Sub

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

7   голосов , оценка 4.429 из 5
Похожие ответы