Создание консолидированного отчета
Рассмотрим пример еще одной полезной пакетной обработки. Допустим вам как сотруднику множество подразделений присылает однотипные отчеты и вашей задачей является собрать их в одни файл и переслать руководителю. Либо же вы руководитель, и собираете подобные консолидированные отчеты от подчиненных. Т.е. это простая рутинная работа - скопировать данные из одного файла и вставить его в консолидирующий и так 30 раз. Для этого случая можно сделать пакетную обработку - сохранить все нужные к обработке файлы в одной папке - программа сама создаст сводный файл и проведет копирование однотипных данных из всех файлов в папке в этот файл.
Как всегда важная деталь - файл из которого вы будете запускать этот макрос не должен находится в этот папке, чтобы его преждевременное открытие не вызвало ошибку. Макрос нужно запускать из любого другого открытого файла.
Приведем код
Sub Консолидация()
' Макрос создает книгу и последовательно вставляет на одноименные листы
' данные из всех xls файлов заданной директории начиная со строки FRow.
Const FRow& = 1 ' Номер строки начала сбора данных
Const Sborka$ = "Сборка.xls" ' Имя сборочного файла
Dim FCol&, LCol& ' Переменные номеров первого и последнего столбца для сбора данных
Dim LRow&, LRow_Cel&
Dim wb_Cel As Workbook, wb_Tek As Workbook
Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
Dim MyPath$, MyFileName$, MyFulName$
Dim Uslovie1 As Boolean
' Вызываем функцию GetFolderPath для вызова окна выбора папки
MyPath = GetFolderPath
' Указываем переменную массива файлов (без маски)
MyFileName = Dir(MyPath & "*.xls*")
Uslovie1 = False
' Вызываем функцию Do Until - это цикл перебора похожий на for next
' отличие лишь в том что у него нет второго условия To, он обрабатываем данные до конца
' пока условие указанное в нем выполняется
Do Until MyFileName = ""
If MyFileName <> Sborka Then
MyFulName = MyPath & MyFileName
Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
If Not Uslovie1 Then
Set wb_Cel = ActiveWorkbook
ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8
Uslovie1 = True
Else
Set wb_Tek = ActiveWorkbook
'вызываем циклы for each для перебора массива ячеек в копируемых диапазонах
' программа определяет так называемую текущую область - диапазон с заполненными данными
For Each Sh_Cel In wb_Cel.Sheets
With Sh_Cel
FCol = .UsedRange.Cells(1, 1).Column
LCol = .UsedRange.Columns.Count + FCol - 1
' Чтобы итоговые таблички вставлились в сводный файл удобочитаемо
' укажем, что между копируемыми диапазонами нужно вставить пустую строку - '(.Row+2)
LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 2
End With
For Each Sh_Tek In wb_Tek.Sheets
If Sh_Tek.Name = Sh_Cel.Name Then
With Sh_Tek
LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
If LRow >= FRow Then
.Cells.CurrentRegion.Copy Sh_Cel.Cells(LRow_Cel, 1)
End If
End With
End If
Next Sh_Tek
Next Sh_Cel
Workbooks(MyFileName).Close SaveChanges:=False
End If
End If
MyFileName = Dir
Loop
End Sub
Данный код скопирует все данные с первых листов всех отчетов в папке и вставит их через строчку в файл сводный. Сохраните его в книге учет производства, назначьте кнопку и опробуйте на полученных данных более ранней групповой обработки отчетов себестоимость, либо же попробуйте на других данных (например на отчетах не привязанных позиций).
Строку вызова этого файла можно вставить в код пакетной обработки отчетов себестоимость, сразу за строчкой вызова в ней основного макроса. Тогда после обработки программа сама создаст сводных отчет. Также код можно расширить удалением уже не нужных начальных файлов, к самом конце.
Как всегда важная деталь - файл из которого вы будете запускать этот макрос не должен находится в этот папке, чтобы его преждевременное открытие не вызвало ошибку. Макрос нужно запускать из любого другого открытого файла.
Приведем код
Sub Консолидация()
' Макрос создает книгу и последовательно вставляет на одноименные листы
' данные из всех xls файлов заданной директории начиная со строки FRow.
Const FRow& = 1 ' Номер строки начала сбора данных
Const Sborka$ = "Сборка.xls" ' Имя сборочного файла
Dim FCol&, LCol& ' Переменные номеров первого и последнего столбца для сбора данных
Dim LRow&, LRow_Cel&
Dim wb_Cel As Workbook, wb_Tek As Workbook
Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
Dim MyPath$, MyFileName$, MyFulName$
Dim Uslovie1 As Boolean
' Вызываем функцию GetFolderPath для вызова окна выбора папки
MyPath = GetFolderPath
' Указываем переменную массива файлов (без маски)
MyFileName = Dir(MyPath & "*.xls*")
Uslovie1 = False
' Вызываем функцию Do Until - это цикл перебора похожий на for next
' отличие лишь в том что у него нет второго условия To, он обрабатываем данные до конца
' пока условие указанное в нем выполняется
Do Until MyFileName = ""
If MyFileName <> Sborka Then
MyFulName = MyPath & MyFileName
Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
If Not Uslovie1 Then
Set wb_Cel = ActiveWorkbook
ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8
Uslovie1 = True
Else
Set wb_Tek = ActiveWorkbook
'вызываем циклы for each для перебора массива ячеек в копируемых диапазонах
' программа определяет так называемую текущую область - диапазон с заполненными данными
For Each Sh_Cel In wb_Cel.Sheets
With Sh_Cel
FCol = .UsedRange.Cells(1, 1).Column
LCol = .UsedRange.Columns.Count + FCol - 1
' Чтобы итоговые таблички вставлились в сводный файл удобочитаемо
' укажем, что между копируемыми диапазонами нужно вставить пустую строку - '(.Row+2)
LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 2
End With
For Each Sh_Tek In wb_Tek.Sheets
If Sh_Tek.Name = Sh_Cel.Name Then
With Sh_Tek
LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
If LRow >= FRow Then
.Cells.CurrentRegion.Copy Sh_Cel.Cells(LRow_Cel, 1)
End If
End With
End If
Next Sh_Tek
Next Sh_Cel
Workbooks(MyFileName).Close SaveChanges:=False
End If
End If
MyFileName = Dir
Loop
End Sub
Данный код скопирует все данные с первых листов всех отчетов в папке и вставит их через строчку в файл сводный. Сохраните его в книге учет производства, назначьте кнопку и опробуйте на полученных данных более ранней групповой обработки отчетов себестоимость, либо же попробуйте на других данных (например на отчетах не привязанных позиций).
Строку вызова этого файла можно вставить в код пакетной обработки отчетов себестоимость, сразу за строчкой вызова в ней основного макроса. Тогда после обработки программа сама создаст сводных отчет. Также код можно расширить удалением уже не нужных начальных файлов, к самом конце.
Комментарии
Отправить комментарий