如何用VBA将PivotTable完整复制到新文件并保留格式样式？

原代码问题分析 #

1. 未初始化newWb对象，会触发运行时错误
2. 使用xlPasteValues+xlPasteFormats的粘贴逻辑，会将透视表转为普通单元格区域，不仅丢失透视表的交互属性，还会遗漏部分格式（如单元格填充色）

修改后的VBA代码 #

Sub CopyPivotTablesWithFullFormatting()
    Dim wb As Workbook, newWb As Workbook
    Dim pt1 As PivotTable, pt2 As PivotTable
    Dim newFileName As String
    Dim targetSheet As Worksheet
    Dim pt1LastRow As Long
    
    ' 初始化工作簿对象
    Set wb = ThisWorkbook
    Set newWb = Workbooks.Add ' 创建新工作簿
    Set targetSheet = newWb.Sheets(1) ' 指定目标工作表
    
    ' 绑定原透视表
    Set pt1 = wb.Sheets("GDM-MO").PivotTables("Tableau croisé dynamique1")
    Set pt2 = wb.Sheets("GDM-MO").PivotTables("Tableau croisé dynamique2")
    
    ' 刷新原透视表
    pt1.RefreshTable
    pt2.RefreshTable
    
    ' 复制第一个透视表（保留透视表结构+所有格式）
    pt1.Copy Destination:=targetSheet.Range("A4")
    ' 同步行高和列宽，确保尺寸完全匹配
    pt1.TableRange2.Copy
    targetSheet.Range("A4").PasteSpecial Paste:=xlPasteColumnWidths
    targetSheet.Range("A4").PasteSpecial Paste:=xlPasteRowHeights
    
    ' 获取第一个透视表的最后一行
    pt1LastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 复制第二个透视表
    pt2.Copy Destination:=targetSheet.Range("A" & pt1LastRow + 6)
    ' 同步行高列宽
    pt2.TableRange2.Copy
    targetSheet.Range("A" & pt1LastRow + 6).PasteSpecial Paste:=xlPasteColumnWidths
    targetSheet.Range("A" & pt1LastRow + 6).PasteSpecial Paste:=xlPasteRowHeights
    
    ' 添加标题
    With targetSheet.Range("A2")
        .Value = "First Table"
        .Font.Bold = True
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Size = 11
    End With
    
    With targetSheet.Range("A" & pt1LastRow + 3)
        .Value = "Second Table"
        .Font.Bold = True
        .Font.Underline = xlUnderlineStyleSingle
        .Font.Size = 11
    End With
    
    ' 保存新工作簿
    newFileName = "Extract tables (" & wb.Name & ").xlsx"
    newWb.SaveAs Filename:=ThisWorkbook.Path & "\" & newFileName
End Sub

关键改进点 #

• 直接复制透视表对象：使用PivotTable.Copy方法，完整复制原透视表的交互属性、样式（包括单元格颜色、字体格式）
• 同步行高列宽：通过单独粘贴行高和列宽，确保新表尺寸与原表完全一致
• 修复对象初始化问题：补充newWb的创建逻辑，避免运行时异常

内容的提问来源于stack exchange，提问作者Maoane