Имеется выгрузка данных проектов (их число может быть разное). Выглядит она так же, как и в файле "Пример базы данных", который я прикладываю. Макрос ниже позволяет разбить этот массив данных по отдельным книгам и сохранить в определенном месте (критерий -- названия проектов в столбце А):
Скрытый текст
Код
Sub Framed()Dim arr()
Dim iArr()
Dim dic As Object
Dim xlWb As Workbook
Dim I&, J&, n&, iKey
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("Spreadsheet")
arr = .Range("A1:R" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
End With
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
With dic
For I = 2 To UBound(arr)
ReDim iArr(17, 0)
.Add arr(I, 1), Empty
If Err <> 0 Then
iArr = .Item(arr(I, 1))
n = UBound(iArr, 2) + 1
ReDim Preserve iArr(17, n)
Err.Clear
Else
n = 0
End If
For J = 0 To 17
iArr(J, n) = arr(I, J + 1)
Next
.Item(arr(I, 1)) = iArr
Next
For Each iKey In .Keys
Set xlWb = Workbooks.Add(1)
With xlWb
With .Worksheets(1)
.Name = "Spreadsheet"
.Range("A1").Resize(1, 18) = Application.Index(arr, 1, 0)
.Range("A2").Resize(UBound(dic.Item(iKey), 2) + 1, 18) = Application.Transpose(dic.Item(iKey))
.Cells.EntireColumn.AutoFit
End With
.SaveAs "C:\Users\A670669\Desktop\CATS_DA" & Application.PathSeparator & iKey & ".xlsx"
.Close False
End With
Next
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Далее, я использую макрос для создания сводной таблицы для каждой вновь созданной книги. То есть захожу в каждую, использую макрос, сохраняю, закрываю. Макрос выглядит так:
Скрытый текст
Код
Sub CreatePivotTable()
Dim PTCache As PivotCache
Dim PT As PivotTable
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Pivot").Delete
On Error GoTo 0
' Создание кеша
Set PTCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Range("A1").CurrentRegion)
' Добавление нового листа в сводную таблицу
Worksheets.Add
ActiveSheet.Name = "Pivot"
' Создание сводной таблицы
Set PT = ActiveSheet.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("A3"))
' Добавление полей
With PT
Set AI = PT.PivotFields("Accounting Indicator")
Set Description = PT.PivotFields("Description")
Set Name = PT.PivotFields("Name of Employee or Applicant")
Set Hours = PT.PivotFields("Hours")
Set RateValue = PT.PivotFields("Rate")
Set TotalRub = PT.PivotFields("TOTAL, RUB")
With AI
.Orientation = xlRowField
.Subtotals(1) = False
.Caption = "AI"
.AutoSort xlDescending, "AI"
End With
With Description
.Orientation = xlRowField
.Subtotals(1) = False
End With
With Name
.Orientation = xlRowField
.Subtotals(1) = False
End With
With Hours
.Orientation = xlDataField
.NumberFormat = "0.000"
.Caption = "Hours "
End With
With RateValue
.Orientation = xlDataField
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
.Function = xlMax
.Caption = "Rate "
End With
With TotalRub
.Orientation = xlDataField
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
.Caption = "Total, RUB "
End With
End With
Cells.EntireColumn.AutoFit
End Sub
Подскажите, пожалуйста, как корректно объединить их в один макрос? То есть, мне нужно, чтобы сначала выполнялся макрос разделения массива, затем макрос создания сводной таблицы и только потом это все сохранялось в отдельную книгу = > следующий проект.
Исходные данные и результаты работы каждого макроса прикладываю.