将扁平数据透视表数据转换为表格 - 错误表不能重叠 - Excel Vba

Question

我有一本有 13 页和 9 个枢轴的工作簿。我正在从另一个工作簿复制枢轴并粘贴平面，试图将它们变成表格。然而，我总是遇到问题表重叠的情况。或者只是将第一个扁平枢轴变成桌子。

任何帮助将不胜感激 这是我尝试过的。

Option Explicit
`Sub copyPivots()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim wBook As Workbook, dataSht As Worksheet, ws As Worksheet
    Dim strName As String, dbook As Workbook
    Dim Sht As Worksheet, i As Long, LR As Long
   

    'Clear Contents
    Set dbook = Workbooks("District.xlsm")
    dbook.Activate
    For Each Sht In dbook.Worksheets
        Sht.Cells.ClearContents
    Next Sht
    Set wBook = Workbooks("data.xlsm")
    ' Loop through all sheets in data.xlsm
    For Each Sht In wBook.Worksheets
        ' Check same sheet in District.xlsm
        If SheetExists(Sht.Name, dbook) Then
            Set dataSht = dbook.Sheets(Sht.Name)
            dataSht.Select
            For i = 1 To 9
                Sht.PivotTables("PivotTable" & i).TableRange1.Copy
                LR = dataSht.Range("A" & dataSht.Rows.Count).End(xlUp).Row
                If LR = 1 Then LR = 0
                ' Select the first blank cell in col A
                dataSht.Range("A" & LR + 2).Select
                dataSht.PasteSpecial xlPasteValuesAndNumberFormats
    
    
    With dataSht

   

    Dim rngStart As Range
    Set rngStart = .Range("A3")

    'set counter variable for naming tables
    Dim s As Long
    s = s + 1

    Do

        'create table range
        Dim rngTable As Range
        Set rngTable = .Range(rngStart, rngStart.End(xlDown))

        'create table
        .ListObjects.Add(xlSrcRange, rngTable.Resize(rngTable.Rows.Count, rngStart.End(xlToRight).Column), , xlYes).Name = "Table" & i
         'set style
        .ListObjects("Table" & i).TableStyle = "TableStyleLight9"

        'find next table range start
        Set rngStart = rngTable.End(xlDown).Offset(2)

        s = s + 1

    Loop Until rngStart.Row > LR

End With
          
        
            Next i
            
        End If
    Next Sht
    
    MsgBox "done!"
    'Formatting pivot tables for column adjustment
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub`

Answer 1

如果在每次粘贴后立即创建表格对象会更容易：

Sub copyPivots()

    Dim wBook As Workbook, dataSht As Worksheet, ws As Worksheet
    Dim strName As String, dbook As Workbook, lo As ListObject
    Dim Sht As Worksheet, i As Long, LR As Long, rngPaste As Range
    
    Set dbook = Workbooks("District.xlsm")
    For Each Sht In dbook.Worksheets
        Sht.Cells.ClearContents
    Next Sht
    
    Set wBook = Workbooks("data.xlsm")
    
    For Each Sht In wBook.Worksheets
        If SheetExists(Sht.Name, dbook) Then
            Set dataSht = dbook.Sheets(Sht.Name)
            Set rngPaste = dataSht.Range("A2")
            For i = 1 To 9
                With Sht.PivotTables("PivotTable" & i).TableRange1
                    .Copy
                    rngPaste.PasteSpecial xlPasteValuesAndNumberFormats
                    'convert to table and format
                    Set lo = dataSht.ListObjects.Add(xlSrcRange, _
                              rngPaste.Resize(.rows.count, .Columns.count), , xlYes)
                    lo.Name = "Table" & i
                    lo.TableStyle = "TableStyleLight9"
                    Set rngPaste = rngPaste.Offset(.rows.count + 2) 'next paste position
                End With
                
            Next i
        End If
    Next Sht
    
    MsgBox "done!"
    
End Sub