Excel VBA：复制表格及数据透视表转普通表重复表头问题解决

问题场景 #

编写VBA代码实现：将工作簿中「Data」工作表的所有ListObject表格和数据透视表复制到新工作簿，并将数据透视表转换为普通ListObject表格。但运行后发现，即使粘贴的透视表数据已有表头，转换为ListObject时仍会新增重复表头，尝试xlNo和xlYes参数均无效。

解决方案 #

通过录制宏定位到问题根源：ListObjects.Add方法的参数顺序误用。该方法的第三个参数为可选的Destination，第四个参数才是指定是否包含表头的XlListObjectHasHeaders枚举值。

原错误代码：

Set ptbl = newWs.ListObjects.Add(xlSrcRange, pasteRange.CurrentRegion, xlNo)

修正后代码（跳过第三个参数，用逗号占位，将xlYes放在第四个参数位置）：

Set ptbl = newWs.ListObjects.Add(xlSrcRange, pasteRange.CurrentRegion, ,xlYes)

完整修正代码 #

Sub CopyTablesToNewWorkbook()

    Dim tbl As ListObject, ntbl As ListObject
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim copyRange As Range
    Dim pasteRange As Range
    
    Set newWb = Workbooks.Add
    Set newWs = newWb.Sheets(1)
    
    Set pasteRange = newWs.Range("A1")
    
    For Each tbl In ThisWorkbook.Worksheets("Data").ListObjects
        Set copyRange = tbl.Range
        copyRange.Copy pasteRange
        Set pasteRange = pasteRange.Offset(copyRange.Rows.Count + 1, 0)
    Next tbl
    
    Dim pt As PivotTable
    For Each pt In ThisWorkbook.Worksheets("Data").PivotTables
        If pt.TableRange1.Cells.Count > 1 Then
            pt.TableRange1.Copy
            pasteRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                                                      :=False, Transpose:=False
            Dim ptbl As ListObject
            Set ptbl = newWs.ListObjects.Add(xlSrcRange, pasteRange.CurrentRegion, ,xlYes)
            Set pasteRange = pasteRange.Offset(pt.TableRange1.Rows.Count + 1, 0)

        End If
    Next pt
    
    For Each ntbl In newWs.ListObjects
        ntbl.TableStyle = "TableStyleMedium20"
    Next ntbl
    
End Sub

结果对比 #

• 当前结果（错误状态）：转换后的ListObject表格出现重复表头，原透视表表头下方新增系统生成的表头行
• 期望结果（正确状态）：转换后的ListObject表格仅保留原透视表的表头，无重复内容

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