Консолидация данных из разных книг макрос - 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
Листинг программы
  1. Sub main()
  2.     Dim WbOzenki As Workbook, WbSvod As Workbook
  3.     Dim sh As Worksheet
  4.    
  5.     FileOzenki = Application.GetOpenFilename(filefilter:="Workbooks(*.xls;*.xlsx),*.xls;*.xlsx", _
  6.                 Title:="Выберите файлы с КР_оценки", MultiSelect:=True)
  7.    
  8.     If Not IsArray(FileOzenki) Then Exit Sub
  9.     Application.ScreenUpdating = False
  10.    
  11.     For j = 1 To UBound(FileOzenki)
  12.         Workbooks.Open (FileOzenki(j))
  13.         Set WbOzenki = ActiveWorkbook
  14.         If j = 1 Then
  15.             WbOzenki.SaveAs "КР_сводная"
  16.             Set WbSvod = ActiveWorkbook
  17.             GoTo SledFile
  18.         End If
  19.         WbSvod.Activate
  20.         With WbSvod
  21.             For i = 1 To .Sheets.Count
  22.                 .Sheets(i).Activate
  23.                 For Each sh In WbOzenki.Sheets
  24.                     If sh.Name = .Sheets(i).Name Then
  25.                         sh.Range("B3:B7").Copy
  26.                         .Sheets(i).Range("B3:B7").PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
  27.                     End If
  28.                 Next
  29. SledSheet:
  30.             Next i
  31.         End With
  32.         WbOzenki.Close False
  33. SledFile:
  34.     Next j
  35.     WbSvod.Save
  36.     Application.ScreenUpdating = True
  37. End Sub

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


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

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

7   голосов , оценка 4.429 из 5

Нужна аналогичная работа?

Оформи быстрый заказ и узнай стоимость

Бесплатно
Оформите заказ и авторы начнут откликаться уже через 10 минут
Похожие ответы