Копирование области значений Pivot в макросе
Написал макрос, который делает Pivot таблицу, копирует данные на новый лист, добавляет данные о валюте и конвертирует цены в одну валюту. Подсжажите, как в приложенном файле скопировать область значений FG Item со страницы PivotSheet и вставить их как заголовки на лист CopiedData в ячейку после Price in EUR. Простое копирование не подходит так как FG Item меняет свое содержание в зависимости от исходных данных.
Sub CORE_25_03_2024()
Dim pivotCache As pivotCache
Dim pivotTable As pivotTable
Dim destSheet As Worksheet, copySheet As Worksheet
Dim sourceData As String
sourceData = "Export!R1C1:R1048576C44"
On Error Resume Next
Dim exportSheet As Worksheet
Set exportSheet = ThisWorkbook.Sheets("Export")
On Error GoTo 0
If exportSheet Is Nothing Then
MsgBox "'Export' "
Exit Sub
End If
Set destSheet = Sheets.Add
destSheet.Name = "PivotSheet"
Set pivotCache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, sourceData:=sourceData)
Set pivotTable = pivotCache.CreatePivotTable(TableDestination:=destSheet.Cells(3, 1), TableName:="PivotTable1")
With pivotTable
.ColumnGrand = False
.RowGrand = False
Dim rowFields As Variant
rowFields = Array("Component Item", "Component Desc", "Vendor Part No", "Manufacturer Name", "Commodity Group", "Supplier Name", "Supplier Catalog Price", "Supplier Catalog From Currency")
Dim i As Integer
For i = LBound(rowFields) To UBound(rowFields)
With .PivotFields(rowFields(i))
.Orientation = xlRowField
.Position = i + 1
.LayoutForm = xlTabular
.RepeatLabels = False
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With
Next i
With .PivotFields("FG Item")
.Orientation = xlColumnField
.Position = 1
End With
.AddDataField .PivotFields("Extended Component Quantity"), "Sum of Extended Component Quantity", xlSum
End With
If destSheet.AutoFilterMode Then destSheet.AutoFilterMode = False
destSheet.Columns.AutoFit
Set copySheet = Sheets.Add(After:=Sheets(Sheets.Count))
copySheet.Name = "CopiedData"
Dim columnTitles As Variant
columnTitles = Array("Row Labels", "Component Desc", "Vendor Part No", "Manufacturer Name", "Commodity Group", "Supplier Name", "Supplier Catalog Price", "Supplier Catalog From Currency")
Dim supplierCatalogCurrencyIndex As Integer
Dim foundRow As Long
For i = LBound(columnTitles) To UBound(columnTitles)
Dim sourceColumn As Range
Set sourceColumn = destSheet.Cells.Find(columnTitles(i))
If Not sourceColumn Is Nothing Then
sourceColumn.EntireColumn.Copy Destination:=copySheet.Cells(1, i + 1)
If columnTitles(i) = "Supplier Catalog From Currency" Then
supplierCatalogCurrencyIndex = i + 1
foundRow = sourceColumn.Row
End If
End If
Next i
copySheet.Cells(foundRow, supplierCatalogCurrencyIndex + 1).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
copySheet.Cells(foundRow, supplierCatalogCurrencyIndex + 1).Value = "Price in EUR"
For i = foundRow + 1 To copySheet.Cells(copySheet.Rows.Count, supplierCatalogCurrencyIndex).End(xlUp).Row
copySheet.Cells(i, supplierCatalogCurrencyIndex + 1).Value = "???????? ???????????"
Next i
With copySheet
.Cells(1, 1).Value = "EUR"
.Cells(1, 2).Value = 1
.Cells(1, 3).Value = "USD"
.Cells(1, 4).Value = 0.9
.Cells(1, 5).Value = "JPY"
.Cells(1, 6).Value = 0.09
.Cells(1, 7).Value = "SEK"
.Cells(1, 8).Value = 0.009
End With
ThisWorkbook.Names.Add Name:="EUR", RefersTo:="=" & copySheet.Name & "!B1"
ThisWorkbook.Names.Add Name:="USD", RefersTo:="=" & copySheet.Name & "!D1"
ThisWorkbook.Names.Add Name:="JPY", RefersTo:="=" & copySheet.Name & "!F1"
ThisWorkbook.Names.Add Name:="SEK", RefersTo:="=" & copySheet.Name & "!H1"
copySheet.Columns.AutoFit
For i = foundRow + 1 To copySheet.Cells(copySheet.Rows.Count, supplierCatalogCurrencyIndex).End(xlUp).Row
Dim priceColumn As String
Dim currencyColumn As String
priceColumn = Replace(copySheet.Cells(i, supplierCatalogCurrencyIndex - 1).Address, "$" & i, "")
currencyColumn = Replace(copySheet.Cells(i, supplierCatalogCurrencyIndex).Address, "$" & i, "")
copySheet.Cells(i, supplierCatalogCurrencyIndex + 1).formula = "=" & priceColumn & i & "*INDIRECT(" & currencyColumn & i & ")"
Next i
End Sub
Ответы (1 шт):
Автор решения: rotabor
→ Ссылка
Пока вопрос не ясен, но чтобы чтобы идентифицировать диапазон изменяющегося размера, нужно:
Dim FirstCell as Range, TargetRange as Range
Set TargetRange = Range(FirstCell, FirstCell.End(xlDown))
Этот код выдаёт TargetRange от FirstCell и вниз до непрерывно последней заполненной ячейки.
С учётом предоставленной книги:
Set TargetRange = Range([I4], [I4].End(xlToRight).Offset(0, -1))