将数据透视缓存从一个文件上的数据透视传输到另一个文件上的数据透视？

我需要将 Excel 文件上的数据透视表的缓存安全地传输到另一个文件上的数据透视表中。我怎样才能做到这一点？

这是我现在使用的代码 （请注意，即使源数据透视数据源已被消除，此方法仍然有效）：

Public Sub TransferPivotCache(Source As PivotTable, Target As PivotTable)
    Dim TempSheet As Worksheet
    Set TempSheet = ThisWorkbook.Sheets.Add
    Source.TableRange2.Copy Destination:=TempSheet.Range("A1")
    Target.CacheIndex = TempSheet.PivotTables(1).CacheIndex
    TempSheet.Delete
End Sub

但是，当我导入的数据透视表太大时，我在修改缓存索引属性时会收到错误“内存不足”。之后，即使文件关闭，如果我尝试重新打开它，它也会损坏。有没有更好的方法在数据透视表之间传输数据透视缓存？

如果您的目标是更新另一个针对相同数据的数据透视表，那么另一种方法是创建一个新的PivotCache指向同一个来源。这样，目标工作簿将构建相同的PivotCache无需复制DataTable，这可能是您的内存问题的原因。

Public Sub TransferPivotCache(source As PivotTable, target As PivotTable)
    Dim pivCache As PivotCache, sh As Worksheet, rgData As Range, refData

    ' convert the `SourceData` from `xlR1C1` to `xlA1` '
    source.Parent.Activate
    refData = Application.ConvertFormula(source.SourceData, xlR1C1, xlA1, xlAbsolute)
    If IsError(refData) Then refData = source.SourceData

    If Not IsError(source.Parent.Evaluate(refData)) Then
        ' create a new pivot cache from the data source if it exists '

        Set rgData = source.Parent.Evaluate(refData)
        If Not rgData.ListObject Is Nothing Then Set rgData = rgData.ListObject.Range

        Set pivCache = target.Parent.Parent.PivotCaches.Create( _
          XlPivotTableSourceType.xlDatabase, _
          rgData.Address(external:=True))

        pivCache.EnableRefresh = False
        target.ChangePivotCache pivCache
    Else
        ' copy the pivot cache since the data source no longer exists '

        Set sh = source.Parent.Parent.Sheets.Add
        source.PivotCache.CreatePivotTable sh.Cells(1, 1)
        sh.Move after:=target.Parent  ' moves the temp sheet to targeted workbook '

        ' replace the pivot cache '
        target.PivotCache.EnableRefresh = True
        target.CacheIndex = target.Parent.Next.PivotTables(1).CacheIndex
        target.PivotCache.EnableRefresh = False

        'remove the temp sheet '
        target.Parent.Next.Delete
    End If

End Sub