Копирование области значений 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))
→ Ссылка