[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1278
  • Last Modified:

pivot chart macro

i have the following code to generate a pivot table from a an excelsheet(credit to jeverist,byundt,rorya@EE)
the code i have:

i would  like to know if a pivot chart can be generated along with pivot table.

Sub AddPivot(ByRef PivotSheet As Worksheet, ByRef PivotDestination As Range)
Dim ws As Worksheet, pt_rng As Range, pt As PivotTable

Set ws = PivotSheet
Set pt_rng = Range(ws.[A1], ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, Application.CountA(ws.Rows(1)) - 1))

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=pt_rng).CreatePivotTable _
            TableDestination:=PivotDestination

Set pt = ws.PivotTables(1)

pt.AddFields RowFields:="Weeks Open"
pt.PivotFields("Closure Date").Orientation = xlDataField

'pt.PivotFields("Weeks Open").AutoSort xlAscending, "Weeks Open"

PivotDestination.Offset(1).Group Start:=1, End:=7.99999999, By:=1
pt.PivotFields("Weeks Open").ShowAllItems = True
End Sub
0
ark989
Asked:
ark989
  • 2
  • 2
1 Solution
 
JRatedCommented:
These three lines at the end of you sub should do it...

    Charts.Add
    ActiveChart.SetSourceData PivotDestination
    ActiveChart.Location xlLocationAsNewSheet


So it would look something like this:

Sub AddPivot(ByRef PivotSheet As Worksheet, ByRef PivotDestination As Range)
Dim ws As Worksheet, pt_rng As Range, pt As PivotTable

Set ws = PivotSheet
Set pt_rng = Range(ws.[A1], ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, Application.CountA(ws.Rows(1)) - 1))

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=pt_rng).CreatePivotTable _
            TableDestination:=PivotDestination

Set pt = ws.PivotTables(1)

pt.AddFields RowFields:="Weeks Open"
pt.PivotFields("Closure Date").Orientation = xlDataField

'pt.PivotFields("Weeks Open").AutoSort xlAscending, "Weeks Open"

PivotDestination.Offset(1).Group Start:=1, End:=7.99999999, By:=1
pt.PivotFields("Weeks Open").ShowAllItems = True

Charts.Add
ActiveChart.SetSourceData PivotDestination
ActiveChart.Location xlLocationAsNewSheet

End Sub
0
 
ark989Author Commented:
this is the code i have. i get errors at lines 91 or at lines 13 when i add your code to this
please check:
Sub AddPivot(ByRef PivotSheet As Worksheet, ByRef PivotDestination As Range)
Dim ws As Worksheet, pt_rng As Range, pt As PivotTable

Set ws = PivotSheet
Set pt_rng = Range(ws.[A1], ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, Application.CountA(ws.Rows(1)) - 1))

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=pt_rng).CreatePivotTable _
            TableDestination:=PivotDestination

Set pt = ws.PivotTables(1)

pt.AddFields RowFields:="Weeks Open"
pt.PivotFields("Closure Date").Orientation = xlDataField

'pt.PivotFields("Weeks Open").AutoSort xlAscending, "Weeks Open"

PivotDestination.Offset(1).Group Start:=1, End:=7.99999999, By:=1
pt.PivotFields("Weeks Open").ShowAllItems = True

End Sub

Sub CombineFiles()
Dim wb_new As Workbook, ws As Worksheet, ws_o As Worksheet, ws_c As Worksheet, wb As Workbook, sh As Worksheet
Dim rng As Range, cel As Range, fld As String, fil As String, i As Long

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

fld = ActiveSheet.Range("C3")
fld = fld & Application.PathSeparator

Set wb_new = Workbooks.Add
If wb_new.Worksheets.Count < 2 Then wb_new.Worksheets.Add
For i = 1 To wb_new.Worksheets.Count
    Select Case i
    Case 1
        Set ws_o = wb_new.Worksheets(i)
        ws_o.Name = "Open"
    Case 2
        Set ws_c = wb_new.Worksheets(i)
        ws_c.Name = "Closed"
    Case Else
        wb_new.Worksheets(i).Delete
    End Select
Next i
       
fil = Dir(fld & "*.xls")
Do While (fil <> "")
    Set wb = Workbooks.Open(fld & fil)
    For Each sh In wb.Worksheets
        Select Case Trim(Left(LCase(sh.Name), 5))
        Case "open"
            Set ws = ws_o
        Case "close"
            Set ws = ws_c
        Case Else
            Set ws = Nothing
        End Select
       
        If Not ws Is Nothing Then
            If ws.UsedRange.Cells.Count = 1 Then
                sh.Rows(3).Copy Destination:=ws.Rows(1)
            End If
           
            Set rng = Range(sh.Cells(5, "A"), sh.Cells(sh.Rows.Count, "A").End(xlUp)).Resize(ColumnSize:=sh.UsedRange.Columns.Count)
           
            If Not rng Is Nothing Then
                With ws.Cells(ws.Rows.Count, "A").End(xlUp)
                    rng.Copy Destination:=.Offset(1)
                End With
            End If
        End If
    Next sh
   
    wb.Close SaveChanges:=False
   
    fil = Dir
Loop

For i = 1 To 2
    Select Case i
    Case 1
        Set ws = ws_o
    Case 2
        Set ws = ws_c
    End Select
   
    With ws
        For Each cel In Intersect(ws.UsedRange, ws.Columns("H")).Cells
            If Trim(cel) = "" Then cel = Date
        Next cel
       
        Union(.Columns("B"), .Columns("D:G")).Delete
       
        With .UsedRange.Columns(Application.CountA(.Rows(1))).Offset(0, 1)
            .FormulaR1C1 = "=RC[-1]-RC[-2]"
            .NumberFormat = "General"
            .Cells(1).Value = "Days Open"
        End With
       
        With .UsedRange.Columns(Application.CountA(.Rows(1))).Offset(0, 1)
            .FormulaR1C1 = "=ROUNDUP(RC[-1]/7,0)"
            .NumberFormat = "General"
            .Cells(1).Value = "Weeks Open"
        End With
       
        With .UsedRange
            .Columns.AutoFit
            .Sort Key1:=.Range("D2"), Order1:=xlDescending, Header:=xlGuess
        End With
       
        AddPivot PivotSheet:=ws, PivotDestination:=ws.Range("G3")

    End With
Next i

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

End Sub


0
 
Rory ArchibaldCommented:
Where did you put the code? It would be helpful if you marked the lines that caused errors and told us what the errors are. (I for one am not going to work out which is line 91 and then guess what the error might be)
Regards,
Rory
0
 
JRatedCommented:
Seems there was a range reference to an active sheet that was no longer there once the chart was created. Adding in

Charts.Add
ActiveChart.SetSourceData PivotDestination
ActiveChart.Location xlLocationAsNewSheet
ActiveSheet.Name = ws.Name & " Chart"
ws.Select

should fix the problem as well as name your charts. Here is your new AddPivot Sub:

Sub AddPivot(ByRef PivotSheet As Worksheet, ByRef PivotDestination As Range)
Dim ws As Worksheet, pt_rng As Range, pt As PivotTable

Set ws = PivotSheet
Set pt_rng = Range(ws.[A1], ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(0, Application.CountA(ws.Rows(1)) - 1))

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=pt_rng).CreatePivotTable _
            TableDestination:=PivotDestination

Set pt = ws.PivotTables(1)

pt.AddFields RowFields:="Weeks Open"
pt.PivotFields("Closure Date").Orientation = xlDataField

'pt.PivotFields("Weeks Open").AutoSort xlAscending, "Weeks Open"

PivotDestination.Offset(1).Group Start:=1, End:=7.99999999, By:=1
pt.PivotFields("Weeks Open").ShowAllItems = True

Charts.Add
ActiveChart.SetSourceData PivotDestination
ActiveChart.Location xlLocationAsNewSheet
ActiveSheet.Name = ws.Name & " Chart"
ws.Select

End Sub
0
 
ark989Author Commented:
rorya,
i would post he error in next Question and also would give more details/infregarding the error
thanks

Jrated,
thanks it works perfect.
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now