Macro to add Pivot Charts to a workbook

[zookeepertx]

I'm going to tear my hair out!!! I'm trying to figure out how to get a macro to add Pivot Charts to a workbook and am soon going to wind up in a padded room! I've tried recording a macro doing exactly what I need, but the macro won't work when I try to run it. I've googled all over God's green earth and have tried at least 4 codes that I found there but nothing works. I've tried piecing together code using some/all of the above and NOTHING WORKS!!

Well, actually, I did have one bit of it working on a very small, very basic example of data, but then, when I tried to make it work on some data just a BIT larger than that, it failed again. Now, I've messed with ALL of the attempts so badly that I can't make sense of any of them.
I've been working on this for almost 2 days!!

Ultimately, each of the sections of data - separated by "Method" needs to have it's own Pivot Table and Pivot Chart, all on one sheet in the workbook, one below another.

I'm attaching a shortened version of what I'm working with. The first tab is how the data gets here in the very first place. The Results tab is what the coding I've already made does with it (before arriving at the pivot table part). The second "results" is the one I've been using to work on the Pivot Chart Macro. "Pivot Tables" shows what I want to end up with (just using the top 2 sections for an example.) The Pivot Tables need to be grouped by column P - "Method", then by E - "Out of Range". The data consists of Tracking# - First a Count, Second a % of the Grand Total.

Just to be thorough, here is the coding I made to get from the very original data to the Results tabs:

Sub WebDeliveryDate()
'Jenny 06052015
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

LR = Range("A" & Rows.count).End(xlUp).row
Range("A" & "2" & ":S" & LR).Select
    Selection.Sort Key1:=Range("P1"), Order1:=xlAscending

For i = LR To 2 Step -1
    If Range("P" & i).Value = "APP" Then
        Range("P" & i).Value = "USPS"
    ElseIf Range("P" & i).Value = "DD" Then
        Range("P" & i).Value = "2 Day"
    ElseIf Range("P" & i).Value = "FEDXG" Then
        Range("P" & i).Value = "Ground"
    ElseIf Range("P" & i).Value = "FEDXH" Then
        Range("P" & i).Value = "Home Delivery"
    ElseIf Range("P" & i).Value = "ON" Then
        Range("P" & i).Value = "Overnight"
    Else
        Rows(i & ":" & i).EntireRow.Delete
    End If
Next i

For LR = Cells(Cells.Rows.count, "P").End(xlUp).row To 3 Step -1
     If Cells(LR, "P") <> Cells(LR - 1, "P") Then
         Rows(LR).EntireRow.Insert
     End If
Next LR

FS = Columns("P").Find(What:=Range("P3").Value, SearchDirection:=xlPrevious).row
SS = Columns("P").Find(What:=Range("P" & FS + 2), SearchDirection:=xlPrevious).row
TS = Columns("P").Find(What:=Range("P" & SS + 2), SearchDirection:=xlPrevious).row
FS2 = Columns("P").Find(What:=Range("P" & TS + 2), SearchDirection:=xlPrevious).row

With Range("A1:S1")
    .Copy Range("A" & (FS + 1) & ":S" & (FS + 1) & ",A" & (SS + 1) & ":S" & (SS + 1) & _
    ",A" & (TS + 1) & ":S" & (TS + 1) & ",A" & (FS2 + 1) & ":S" & (FS2 + 1))
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

Here is one of the versions of code that I tried to adapt from one I found online.

Sub CreatePivotTable()
Dim mysheet As Worksheet
Dim pc As PivotCache
Dim pt As PivotTable
Dim pf1 As PivotField
Dim pf2 As PivotField
Dim pf3 As PivotField
Dim pf4 As PivotField
mydata = Range("A1:S6")
    Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, mydata)
    Set pt = pc.CreatePivotTable(Range("A40"), "ItemList")
    Set pf1 = pt.PivotFields("Methdo")
        pf1.Orientation = xlRowField
    Set pf2 = pt.PivotFields("Out of Range")
        pf2.Orientation = xlRowField
    Set pf3 = pt.PivotFields("Tracking#")
        pf3.Orientation = xlDataField
    Set pf4 = pt.PivotFields("Tracking#")
        pf4.Orientation = xlDataField
        pf4.Caption = "% of Method"
        pf4.Calculation = xlPercentOfTotal
        pf4.NumberFormat = "0.00%"
    CreatePivotChart
End Sub
Sub CreatePivotChart()
Dim chobj As ChartObject
Dim ch As Chart
Set mycheet = Sheets("Result(2)")
Set chobj = mycheet.ChartObjects.Add(300, 500, 300, 150)
Set chobj = chobj.Chart
ch.SetSourceData pt.TableRange1
cl.ChartType = xlColumnClustered
chobj.Name = "EChart1"
End Sub

Here's something else I've tried

Sub TestPivot()
' TestPivot Macro
    Range("A1:S37").Select
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "L29391_289 (5)!R1C1:R37C19", Version:=xlPivotTableVersion14). _
        CreatePivotTable TableDestination:="Sheet8!R1C1", TableName:="PivotTable2" _
        , DefaultVersion:=xlPivotTableVersion14
    Sheets("Sheet8").Select
    Cells(1, 1).Select
    ActiveSheet.Shapes.AddChart.Select
    ActiveChart.ChartType = xlColumnClustered
    ActiveChart.SetSourceData Source:=Range("Sheet8!$A$1:$C$18")
    ActiveSheet.Shapes("Chart 1").IncrementLeft 192
    ActiveSheet.Shapes("Chart 1").IncrementTop 15
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Method")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("OutOfRange")
        .Orientation = xlRowField
        .Position = 2
    End With
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Tracking#"), "Count of Tracking#", xlCount
    ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables( _
        "PivotTable2").PivotFields("Tracking#"), "Count of Tracking#2", xlCount
    ActiveSheet.PivotTables("PivotTable2").PivotFields("Count of Tracking#"). _
        Caption = "Count"
    With ActiveSheet.PivotTables("PivotTable2").PivotFields("Count of Tracking#2")
        .Caption = "% of Method"
        .Calculation = xlPercentOfTotal
        .NumberFormat = "0.00%"
    End With
End Sub

I assume nobody wants to slog through the other 5 versions of the code that I have at this point, so I'll save you looking at them.

I'm getting seriously furious with this!! PLEASE can someone help me?

EDITED: Okay, I forgot to attach my workbook to my post and now it won't let me attach via "Edit Post" or "Reply". Why does it hate me??

Jenny

 

[V_Malkoti]

Replace your curreent PivotChart subroutine code with this. Then run your complete code without stepping or any breakpoints, and let me know how it goes.

Sub CreatePivotChart2(chartData As Range, chartName As String)
    Dim chObj As ChartObject
    Dim ch As Chart
    
    Set mySheet = ActiveWorkbook.Sheets("Pivot Charts")
    For Each oCht In mySheet.ChartObjects
        If oCht.Name = chartName Then oCht.Delete
        'Debug.Print oCht.SeriesCollection.Item(1).Formula
    Next oCht
    chartData.Select
    Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, iChartWidth, iChartHeight)
    'Debug.Print oCht.SeriesCollection.Item(1).Formula
    chObj.Chart.ChartWizard Source:=chartData, gallery:=xlColumnClustered
    chObj.Name = chartName
End Sub

 

[V_Malkoti]

Further updated code to remove % column from Chart and remove that from chat legend as well.

Sub CreatePivotChart2(chartData As Range, chartName As String)
    Dim chObj As ChartObject
    Dim ch As Chart
    
    Set mySheet = ActiveWorkbook.Sheets("Pivot Charts")
    For Each oCht In mySheet.ChartObjects
        If oCht.Name = chartName Then oCht.Delete
    Next oCht
    chartData.Select
    Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, iChartWidth, iChartHeight)
    chObj.Chart.ChartWizard Source:=chartData, gallery:=xlColumnClustered
    chObj.Name = chartName
    
    chObj.Chart.SeriesCollection(2).ChartType = xlLine
    chObj.Chart.SeriesCollection(2).Select
    Selection.Format.Line.Visible = msoFalse
    
    chObj.Chart.Legend.LegendEntries(2).Delete
End Sub

Everything appears to be working fine in my workbook no matter how I run it or how many times I run it. Test it and let me know if you still see any issues.

 

[zookeepertx]

Replace your curreent PivotChart subroutine code with this. Then run your complete code without stepping or any breakpoints, and let me know how it goes.

Sub CreatePivotChart2(chartData As Range, chartName As String)
    Dim chObj As ChartObject
    Dim ch As Chart
    
    Set mySheet = ActiveWorkbook.Sheets("Pivot Charts")
    For Each oCht In mySheet.ChartObjects
        If oCht.Name = chartName Then oCht.Delete
        'Debug.Print oCht.SeriesCollection.Item(1).Formula
    Next oCht
    chartData.Select
    Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, iChartWidth, iChartHeight)
    'Debug.Print oCht.SeriesCollection.Item(1).Formula
    chObj.Chart.ChartWizard Source:=chartData, gallery:=xlColumnClustered
    chObj.Name = chartName
End Sub

HAH! That works beautifully!! You rock! Thank you so much!

I've created another problem; hopefully an easy one. When I put this together with the code that takes the original data and gets it into the form we started the Pivotting from, everything still works, except that all of the charts appear to be shortened down so that they have no height at all! They're each just a horizontal line. I can grab the bottom and "grow" them to the correct height, so the data is THERE. The charts just seem to have no height to them.

If I run the 2 macros separately, everything is good.

In stepping through the combination, the problem occurs at this line:

Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, iChartWidth + 200, iChartHeight)

When I hover over iChartLeft, iChartWidth or iChart Height, it says "Empty"; when I hover over chartData.Top, it says zero.

Here is the entire combination of the 2 codes:

Sub WebDeliveryDate2()
'JennyDrumm 06052015
LR = Range("A" & Rows.count).End(xlUp).row
Range("A" & "2" & ":S" & LR).Select
    Selection.Sort Key1:=Range("P1"), Order1:=xlAscending
For i = LR To 2 Step -1
    If Range("P" & i).Value = "APP" Then
        Range("P" & i).Value = "USPS"
    ElseIf Range("P" & i).Value = "DD" Then
        Range("P" & i).Value = "2 Day"
    ElseIf Range("P" & i).Value = "FEDXG" Then
        Range("P" & i).Value = "Ground"
    ElseIf Range("P" & i).Value = "FEDXH" Then
        Range("P" & i).Value = "Home Delivery"
    ElseIf Range("P" & i).Value = "ON" Then
        Range("P" & i).Value = "Overnight"
    Else
        Rows(i & ":" & i).EntireRow.Delete
    End If
Next i
For LR = Cells(Cells.Rows.count, "P").End(xlUp).row To 3 Step -1
     If Cells(LR, "P") <> Cells(LR - 1, "P") Then
         Rows(LR).EntireRow.Insert
     End If
Next LR
FS = Columns("P").Find(what:=Range("P3").Value, SearchDirection:=xlPrevious).row
SS = Columns("P").Find(what:=Range("P" & FS + 2), SearchDirection:=xlPrevious).row
TS = Columns("P").Find(what:=Range("P" & SS + 2), SearchDirection:=xlPrevious).row
FS2 = Columns("P").Find(what:=Range("P" & TS + 2), SearchDirection:=xlPrevious).row
With Range("A1:S1")
    .Copy Range("A" & (FS + 1) & ":S" & (FS + 1) & ",A" & (SS + 1) & ":S" & (SS + 1) & _
    ",A" & (TS + 1) & ":S" & (TS + 1) & ",A" & (FS2 + 1) & ":S" & (FS2 + 1))
End With

WorkingPivotTable2
End Sub

Sub WorkingPivotTable2()
    Dim iChartHeight As Integer
Dim iChartWidth As Integer
Dim iChartLeft As Integer
Dim mySheet As Worksheet, pivotSheet As Worksheet
    Dim pc As PivotCache
    Dim pt As PivotTable
    Dim pf1 As PivotField
    Dim pf2 As PivotField
    Dim pf3 As PivotField
    Dim pf4 As PivotField
    Dim mydata As Range
    Dim strFirstRowAddress As String, fromRow As Long, toRow As Long, lastRow As Long, boolRun As Boolean
    Dim oCell As Range
    Dim oPivotPos As Range, strPivotName As String, oldPivotRow As Long, newPivotRow As Long
    
    Set mySheet = ActiveWorkbook.Sheets(1)
    iChartHeight = 150
    iChartWidth = 300
    iChartLeft = 200
    
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets("Pivot Charts").Delete
    Err.Clear
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "Pivot Charts"
    Set pivotSheet = ActiveWorkbook.Sheets("Pivot Charts")
    
    fromRow = 1
    strFirstRowAddress = mySheet.Range("A1").Address
    lastRow = mySheet.Range("A1").End(xlDown).row
    boolRun = True
    Set oPivotPos = pivotSheet.Range("A1")
    Set oCell = mySheet.Range("A:A").Find(what:="Ticket", LookIn:=xlValues)
    While Not oCell Is Nothing And boolRun
        If oCell.Address <> strFirstRowAddress Then
            toRow = oCell.row - 1
        Else
            toRow = lastRow
            boolRun = False
        End If
        strPivotName = "ItemList_" & fromRow & "_" & toRow
        Set mydata = mySheet.Range("A" & fromRow & ":S" & toRow)
        Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, mydata)
        Set pt = pc.CreatePivotTable(oPivotPos, strPivotName)
        Set pf1 = pt.PivotFields("Method")
            pf1.Orientation = xlRowField
        Set pf2 = pt.PivotFields("OutofRange")
            pf2.Orientation = xlRowField
        Set pf3 = pt.PivotFields("Tracking#")
            pf3.Orientation = xlDataField
            pf3.Function = xlCount
            pf3.Caption = "Count"
        Set pf4 = pt.PivotFields("Tracking#")
            pf4.Orientation = xlDataField
            pf4.Function = xlCount
            pf4.Caption = "% of Method"
            pf4.Calculation = xlPercentOfTotal
            pf4.NumberFormat = "0.00%"
        
        CreatePivotChart2 pt.TableRange1, "Chart_" & fromRow & "_" & toRow
        
        ' Position for next pivot
        oldPivotRow = oPivotPos.row
        newPivotRow = pt.DataLabelRange.End(xlDown).row + 4
        If ((newPivotRow - oldPivotRow) < (iChartHeight / pivotSheet.StandardHeight)) Then
            newPivotRow = oldPivotRow + Round(iChartHeight / pivotSheet.StandardHeight) + 2
        End If
        Set oPivotPos = pivotSheet.Range("A" & newPivotRow)
        fromRow = toRow + 1
        Set oCell = mySheet.Range("A:A").FindNext(oCell)
    Wend
    
    ' To take care of column resizing that keeps on happening when pivot is created.
    For Each oCht In pivotSheet.ChartObjects
        oCht.Left = 200
    Next oCht
    
End Sub

Sub CreatePivotChart2(chartData As Range, chartName As String)
    Dim chObj As ChartObject
    Dim ch As Chart
    
    Set mySheet = ActiveWorkbook.Sheets("Pivot Charts")
    For Each oCht In mySheet.ChartObjects
        If oCht.Name = chartName Then oCht.Delete
        'Debug.Print oCht.SeriesCollection.Item(1).Formula
    Next oCht
    chartData.Select
    Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, iChartWidth + 200, iChartHeight)
    'Debug.Print oCht.SeriesCollection.Item(1).Formula
    chObj.Chart.ChartWizard Source:=chartData, gallery:=xlColumnClustered
    chObj.Name = chartName
End Sub

Hopefully, this is something easy. If neccessary, I can give it to my co-worker as 2 separate macros; I just hate to quit on it and not have it act right.

Thanks

Jenny

 

[V_Malkoti]

Looks like you moved first three statements from my code inside the subroutine. Those statements declare global variables.

Dim iChartHeight As Integer
Dim iChartWidth As Integer
Dim iChartLeft As Integer

Sub CreatePivotTable2()

became

Sub WorkingPivotTable2()
    Dim iChartHeight As Integer
Dim iChartWidth As Integer
Dim iChartLeft As Integer

Move these variable declarations in your macro module outside subroutines.

 

[zookeepertx]

Looks like you moved first three statements from my code inside the subroutine. Those statements declare global variables.


became

Sub WorkingPivotTable2()
    Dim iChartHeight As Integer
Dim iChartWidth As Integer
Dim iChartLeft As Integer

Move these variable declarations in your macro module outside subroutines.

Oh, DUH! You're right I did; I forgot! But I did that because when I tried to run it with the declarations between the first and second sets of coding, they kept ending up ABOVE the line separating the first code from the second code. That ended up with an error. I never thought to put the declarations at the VERY top of the whole thing!

WOOOHOOO!!!! You've made my day! Well, actually, my week!

Thank you SO much! And have a great weekend!

Jenny

 

[V_Malkoti]

Glad I could help. And learned something along the way.

In your code I see that PivotChart function is the old one. Update that with latest one I posted and that solves your "Hide % column" problem as well.

 

[zookeepertx]

Glad I could help. And learned something along the way.

In your code I see that PivotChart function is the old one. Update that with latest one I posted and that solves your "Hide % column" problem as well.

Oops, you're right again! I think I was probably doing something else and didn't even see that last improvement you made. I've got it in there and the whole thing is absolutely perfect now!

(You know, when we (the message board & I) manage to create a difficult macro like this one, I re-create the data several times in a row, just to run the macro and watch it work. There's a chance that I might be too easy to amuse, LOL! )

Jenny

 

[V_Malkoti]

That's actually a good practice - testing your code multiple times with different sets of data. It helps spot issues that appear because of scenarios that developer didn't think of.

 

[zookeepertx]

That's actually a good practice - testing your code multiple times with different sets of data. It helps spot issues that appear because of scenarios that developer didn't think of.

Yeah - "testing my code"! That sounds a LOT better than "playing with a new toy", LOL!