Need help on macro to create a Table and PivotTable from active cell

[General Ledger]

Dear All,

I am trying to create a macro that will create a Table in Excel 2010 and create a PivotTable (PT) based on the new Table. Below I have the macro that creates a PT and adjusts some of the settings.

I am having trouble finding code to identify the current region of the active cell and create a Table. Note there may already exist Tables in the active workbook. Therefore, the code needs to name the new Table the next available number in the collection of Tables.

Once the Table is created, it needs to be the source of the data for the new PT.


Sub CreatePivotTable()
Dim PTCache As PivotCache
Dim PT As PivotTable

' Create the cache
Set PTCache = ActiveWorkbook.PivotCaches.Create( _
SourceType:=xlDatabase, _
SourceData:=Range("a1").CurrentRegion)

' Add a new sheet for the pivot table
Worksheets.Add

' Create the pivot table
Set PT = ActiveSheet.PivotTables.Add( _
PivotCache:=PTCache, _
TableDestination:=Range("a3"))

' Add the fields
With PT
.PivotFields(1).Orientation = xlPageField
.PivotFields(2).Orientation = xlRowField
.PivotFields(3).Orientation = xlColumnField
.PivotFields(4).Orientation = xlDataField
End With

With PT
.HasAutoFormat = False
.PreserveFormatting = True
.InGridDropZones = True
.RepeatItemsOnEachPrintedPage = True
.RowAxisLayout xlTabularRow
.RepeatAllLabels xlRepeatLabels
End With

End Sub

Thank you so much,

GL

 

[AlphaFrog]

Sub CreatePivotTable()

    Dim PT      As PivotTable
    Dim PTName  As String
    Dim wsData  As Worksheet
    Dim wsPT    As Worksheet

    ' Data worksheet
    Set wsData = ActiveSheet

    ' Add a new sheet for the pivot table
    Worksheets.Add After:=Sheets(Sheets.Count)
    Set wsPT = Sheets(Sheets.Count)

    ' Create the pivot table
    PTName = "PT1"
    ActiveWorkbook.PivotCaches.Add( _
        SourceType:=xlDatabase, _
        SourceData:=wsData.Range("A1").CurrentRegion).CreatePivotTable _
            TableDestination:=wsPT.Range("A3"), _
            TableName:=PTName
    Set PT = wsPT.PivotTables(PTName)

    ' Add the fields
    With PT
        .PivotFields(1).Orientation = xlPageField
        .PivotFields(2).Orientation = xlRowField
        .PivotFields(3).Orientation = xlColumnField
        .PivotFields(4).Orientation = xlDataField
        
        .HasAutoFormat = False
        .PreserveFormatting = True
        '.InGridDropZones = True
        .RepeatItemsOnEachPrintedPage = True
        '.RowAxisLayout xlTabularRow
        '.RepeatAllLabels xlRepeatLabels
    End With
    
    ' Hide pivot table toolbars
    ActiveWorkbook.ShowPivotTableFieldList = False
    Application.CommandBars("PivotTable").Visible = False

End Sub