Charts being duplicated

M

mikeymay

Well-known Member
Joined
Jan 17, 2006
Messages
1,655
Office Version
  1. 365
Platform
  1. Windows
I have a worksheet that holds a number of pie charts that are refreshed with dynamic ranges as part of a loop.

When the process to refresh the charts is completed, some of the charts are duplicated and overlay the original chart.

There isn't anything in my code that copies a chart and it is only certain charts that are copied/duplicated.

In total there are 126 pie charts in the sheet and only a specific 30 are being duplicated.

The loop is creating a dashboard output for regions and it seems that on each loop these specific charts are being duplicated.

Could anyone provide some help with this as it is slowing down and to some degree bulking up the size of the file.

Code is posted below but it is quite lengthy


TIA
Code: 
[B][U]Module1[/U][/B]

Option Explicit

Sub Outputs()

Dim rngRegion As Range

Dim strRSM As String

Dim intASMD As Integer
Dim intASMC As Integer
Dim intASMM As Integer
Dim intATSM As Integer
Dim intAll As Integer

'Check if CRM data has been imported
If Range("FD_ImportCRM") = False Then
   MsgBox ("The CRM Dashboard data hasn't been imported"), vbExclamation, "Error"
   
   Exit Sub
   Else
End If

'get date ranges
dtEnd = Range("FD_MonthEnd")
dtStart = Range("FD_MonthStart")

Application.ScreenUpdating = False
Application.Calculation = xlManual

Set wbPP = ActiveWorkbook

'Start with outputs
Set rngRegion = Sheets("File Admin").Range("FA_RegionsStart").Offset(1, 0)

Do Until rngRegion = ""
   strRegion = rngRegion
   
   CRMDashboardRegion

   Set rngRegion = rngRegion.Offset(1, 0)
Loop

Set rngRegion = Nothing

StatusHide

'Application.ScreenUpdating = True
'Application.Calculation = xlAutomatic

Set wsCRMPT = Nothing

Set wbPP = Nothing

MsgBox ("The .pdf outputs have been created in the appropriate folder"), vbInformation, "Outputs Created"

End Sub


[B][U]Module2[/U][/B]
Option Explicit

Dim ptPivotTable As PivotTable
Dim ptItem As PivotItem

Dim rngActivity As Range

Dim strPTType As String
Dim strPTPeriod As String
Dim strPerson As String
Dim strPartType As String
Dim strFillType As String

Dim intPersonCount As Integer
Dim intCount As Integer
Dim intClear As Integer

Sub CRMDashboardRegion()

Dim rngRole As Range
Dim rngPerson As Range
Dim rngPrint As Range

Dim strRole As String

Dim intRoles As Integer
Dim intRowOffset As Integer
Dim intTotalPeople As Integer

Range("CRMD_AllRows").EntireRow.Hidden = False

intClear = Range("CRMDA_ActivityCount")

'>>>>>>>>>>>>>>>>>>>>>Refresh PTs and set up for region and date
strStatus = "CRM Dashboard " & vbCr & strRegion & vbCr & "Refreshing all Pivot Tables"

StatusShow

'month activity
Set wsCRMPT = Sheets("CRM Dashboard PT")

'wsCRMPT.Select

Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardActivityMonth")

strPTPeriod = "Month"
strPTType = ""

CRMPTRefresh

'Month Participant
Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardParticipantMonth")

strPTPeriod = "Month"
strPTType = "Participant"

CRMPTRefresh

'annual activity
Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardActivityAnnual")

strPTPeriod = "Annual"
strPTType = ""

CRMPTRefresh

'annual Participant
Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardParticipantAnnual")

strPTPeriod = "Annual"
strPTType = "Participant"

CRMPTRefresh

'Month customer
Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardCustMonth")

strPTPeriod = "Month"
strPTType = "Customer"

CRMPTRefresh

'annual customer
Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardCustAnnual")

strPTPeriod = "Annual"
strPTType = "Customer"

CRMPTRefresh

Calculate

'>>>>>>>>>>>>>>>>>>>>>LOOP THROUGH RSD/ROLES/PEOPLE
'RSD
strPerson = Range("CRMDPT_RSD")

strStatus = "CRM Dashboard" & vbCr & strRegion & vbCr & strPerson

StatusShow

'Add formulas to Part col to get total participant hours
Set rngActivity = Range("CRMD_RSDActivityMonth")

strPartType = "Month"

'Remove strPerson from Month Participant PT
CRMProcessForAll

'Add formulas to Part col to get total participant hours
Set rngActivity = Range("CRMD_RSDActivityYTD")

strPartType = "Annual"

CRMProcessForAll

'Update chart for RSD
CRMRefreshCharts

'>>>>>>>>>>>>>>>>>>>>>Roles
intRoles = 4
intCount = 0
intRowOffset = Range("CRMD_RowOffset")

Set rngRole = Range("CRMD_RolesStart")

Do Until intCount = intRoles
   'get role desc
   strRole = Range("CRMD_RolesStart").Offset(intCount * intRowOffset, 0)
   
   strStatus = "CRM Dashboard" & vbCr & strRegion & vbCr & strRole

   StatusShow
   
   'find role in roles/names table in PT sheet
   Set rngPerson = Range("CRMDPT_RSD").Offset(1, 0)
   
   Do Until rngPerson = strRole
      Set rngPerson = rngPerson.Offset(0, 1)
   Loop
   
   'Get number of people in the role
   intTotalPeople = rngPerson.Offset(-1, 0)
   
   If intTotalPeople = 0 Then
      Range("CRMD_" & Replace(strRole, " - ", "")).EntireRow.Hidden = True
      Else
      intPersonCount = 1
      
      Do Until intPersonCount > intTotalPeople
         Set rngPerson = rngPerson.Offset(1, 0)
         
         'find 1st person in rol column
         Do Until rngPerson <> ""
            Set rngPerson = rngPerson.Offset(1, 0)
         Loop
      
         'get name of person in role
         strPerson = rngPerson
         
         'Add formulas to Part col to get total participant hours
         Set rngActivity = Range("CRMD_RoleActivityMonth").Offset(intCount * intRowOffset, 0)
         
         strPartType = "Month"
         
         CRMProcessForAll
         
         'Add formulas to Part col to get total participant hours
         Set rngActivity = Range("CRMD_RoleActivityYTD").Offset(intCount * intRowOffset, 0)
         
         strPartType = "Annual"
         
         CRMProcessForAll
         
         intPersonCount = intPersonCount + 1
      Loop
      
      Set rngPerson = Nothing
   End If
   
   intCount = intCount + 1
Loop

Set rngRole = Nothing

'>>>>>>>>>>>>>>>>>>>>>People
intCount = 0

Set rngPerson = Range("CRMD_PeopleStart")

intPersonCount = 0

Do Until rngPerson.Offset(intCount * intRowOffset, 0) = ""
   'get role desc
   strPerson = Range("CRMD_PeopleStart").Offset(intCount * intRowOffset, 0)
   
   strStatus = "CRM Dashboard" & vbCr & strRegion & vbCr & strPerson

   StatusShow
   
   'Add formulas to Part col to get total participant hours
   Set rngActivity = Range("CRMD_PersonActivityMonth").Offset(intCount * intRowOffset, 0)
   
   strPartType = "Month"
   
   CRMProcessForAll
   
   'Add formulas to Part col to get total participant hours
   Set rngActivity = Range("CRMD_PersonActivityYTD").Offset(intCount * intRowOffset, 0)
   
   strPartType = "Annual"
   
   CRMProcessForAll
      
   intCount = intCount + 1
Loop

Calculate

CRMRefreshCharts

Set rngActivity = Nothing

'Print out Region
Set rngPrint = Range("CRMD_PrintRangeRegion")

Calculate

'Output to .pdf
strStatus = "CRM Dashboard" & vbCr & "Saving " & strRegion & ".pdf"

StatusShow

Set rngPrint = Range(rngPrint, rngPrint.Offset(Range("CRMD_Rows") - 2, 0))

ActiveSheet.PageSetup.PrintArea = rngPrint.Address

strFolder = ActiveWorkbook.Path & "\Outputs"
strFolder = strFolder & "\" & Range("FD_Year") & "\" & Range("FD_MonthString")

Sheets("CRM Dashboard").Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFolder & "\2.0 CRM Dashboards - " & Range("FD_MonthEndShort") & " - " & strRegion & ".pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

'>>>>>>>>>>>>>>>>>>>>>ASMs - to be developed later
'intCount = 0
'
'Set rngPerson = Range("CRMDPT_ASMStart")
'
'Do Until rngPerson = ""
'   'get role desc
'   strPerson = rngPerson
'
'   'Add formulas to Part col to get total participant hours
'   Set rngActivity = Range("CRMD_PersonActivityMonth").Offset(intCount * intRowOffset, 0)
'
'   strPartType = "Month"
'
'   CRMProcessForAll
'
'   'Add formulas to Part col to get total participant hours
'   Set rngActivity = Range("CRMD_PersonActivityYTD").Offset(intCount * intRowOffset, 0)
'
'   strPartType = "Annual"
'
'   CRMProcessForAll
'
'   intCount = intCount + 1
'Loop
'
'Set rngActivityFills = Range("CRMDA_Activities")
'Set rngCustomerFills = Range("CRMDA_CustomerTypes")
'
'CRMRefreshCharts
'
'
'Set rngActivityFills = Nothing
'Set rngCustomerFills = Nothing
'
'Set rngActivity = Nothing
'Set rngPerson = Nothing
'
'Set wsCRMPT = Nothing
'
'Set rngPrint = Range("CRMD_PrintRange")
'
'Set rngPrint = Range(rngPrint, rngPrint.Offset(Range("CRMD_Rows") - 2, 0))
'
'ActiveSheet.PageSetup.PrintArea = rngPrint.Address
'
'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\Outputs\" & Year(Range("FD_MonthEnd")) & "\" & Month(Range("FD_MonthEnd")) & " - " & Format(Range("FD_MonthEnd"), "mmm yy") & "\CRM Dashboard v1.03.pdf" _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

End Sub

Sub CRMDashboardASM()



End Sub

Sub CRMPTRefresh()

With ptPivotTable
   .PivotCache.Refresh

   If strPTType = "Participant" Then
      .PivotFields("Region").ClearAllFilters
      .PivotFields("Participant").ClearAllFilters
      .PivotFields("Owner").ClearAllFilters
      Else
      .PivotFields("Region").CurrentPage = strRegion
   End If

   If strPTPeriod = "Month" Then
      .PivotFields("Start Date").NumberFormat = "d mmm yy"
   
      For Each ptItem In .PivotFields("Start Date").PivotItems
         If DateValue(ptItem.Name) >= dtStart And DateValue(ptItem.Name) <= dtEnd Then
            ptItem.Visible = True
            Else
            ptItem.Visible = False
         End If
      Next
      
      Set ptItem = Nothing
   
   End If
End With

End Sub

Sub CRMProcessForAll()

'Remove strPerson from Annual Participant PT
If strPartType = "Month" Then
   Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardParticipantMonth")
   Else
   Set ptPivotTable = wsCRMPT.PivotTables("PT_CRMDashboardParticipantAnnual")
End If

CRMOwnerParticipant
   
CRMParticipantHours

End Sub

Sub CRMOwnerParticipant()

With ptPivotTable
   .PivotFields("Owner").ClearAllFilters
   .PivotFields("Participant").ClearAllFilters
   
   .PivotFields("Owner").PivotItems(strPerson).Visible = False
   
   For Each ptItem In .PivotFields("Participant").PivotItems
      If InStr(ptItem.Name, strPerson) > 0 Then
         ptItem.Visible = True
         Else
         ptItem.Visible = False
      End If
   Next
   
   Set ptItem = Nothing
End With

End Sub

Sub CRMParticipantHours()

Dim lngHours As Long

If intPersonCount > 1 Then
   Else
   Range(rngActivity.Offset(0, 2), rngActivity.Offset(intClear - 1, 2)).ClearContents
End If

Do Until rngActivity = ""
   lngHours = rngActivity.Offset(0, 2)
   
   If strPartType = "Month" Then
      rngActivity.Offset(0, 2).Formula = "=IF(" & rngActivity.Address & "="""","""",IFERROR(GETPIVOTDATA(""Hours"",'CRM Dashboard PT'!$AA$8,""New Type""," & rngActivity.Address & "),0))"
      Else
      rngActivity.Offset(0, 2).Formula = "=IF(" & rngActivity.Address & "="""","""",IFERROR(GETPIVOTDATA(""Hours"",'CRM Dashboard PT'!$BT$8,""New Type""," & rngActivity.Address & "),0))"
   End If
   
   rngActivity.Offset(0, 2) = lngHours + rngActivity.Offset(0, 2)
   
   Set rngActivity = rngActivity.Offset(1, 0)
Loop

End Sub

Sub CRMRefreshCharts()

Dim rngChartName As Range
Dim rngAddress As Range

Dim strChart As String
Dim strChartRange As String
Dim strAddress As String

Dim intOffset As Integer
Dim intRows As Integer

Sheets("CRM Dashboard").Select

ActiveSheet.Unprotect Password:=strPassword

'Refresh Role charts
Set rngChartName = Range("FD_ChartsStaticStart").Offset(1, 0)

Do Until rngChartName = ""
   strChart = rngChartName
   strChartRange = rngChartName.Offset(0, 1)
   strAddress = Replace(Range(strChartRange).Address, "$", "")
   intOffset = rngChartName.Offset(0, 2)
   intRows = rngChartName.Offset(0, 3)
   
   If rngChartName.Offset(0, 4) = 0 Then
      Else
      If intRows = 0 Then
         ActiveSheet.ChartObjects(strChart).Visible = False
         Else
         If InStr(strChart, "Activity") > 0 Then
            strFillType = "Activity"
            Else
            strFillType = "Customer"
         End If
         
         ActiveSheet.ChartObjects(strChart).Visible = True
         
         Set rngAddress = Range(strAddress)
         
         Set rngAddress = Range(rngAddress.Offset(intOffset, 0), rngAddress.Offset(intOffset + intRows - 1, 0))
         
         strAddress = Replace(rngAddress.Address, "$", "")
         
         ActiveSheet.ChartObjects(strChart).Activate
            
         ActiveChart.SetSourceData Source:=Range(strAddress)
         
         ActiveChart.PlotArea.Select
         
         Selection.Left = 63.66
         Selection.Top = 32
         Selection.Height = 243.941
         
         ActiveChart.FullSeriesCollection(1).Select
         ActiveChart.FullSeriesCollection(1).ApplyDataLabels
         ActiveChart.FullSeriesCollection(1).DataLabels.Select
          
         Selection.ShowCategoryName = True
         Selection.ShowPercentage = True
         Selection.Separator = "" & Chr(13) & ""
         
         ActiveChart.FullSeriesCollection(1).HasLeaderLines = True
         
         Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue
         
         CRMSliceFill
      End If
   End If
   
   Set rngChartName = rngChartName.Offset(1, 0)
Loop


'Refresh People charts
Set rngChartName = Range("FD_ChartsDynamicStart").Offset(1, 0)

Do Until rngChartName = ""
   strChart = rngChartName
   strChartRange = rngChartName.Offset(0, 1)
   strAddress = Replace(Range(strChartRange).Address, "$", "")
   intOffset = rngChartName.Offset(0, 2)
   intRows = rngChartName.Offset(0, 3)
   
   If intRows = 0 Then
      ActiveSheet.ChartObjects(strChart).Visible = False
      Else
      If InStr(strChart, "Activity") > 0 Then
         strFillType = "Activity"
         Else
         strFillType = "Customer"
      End If
      
      ActiveSheet.ChartObjects(strChart).Visible = True
   
      Set rngAddress = Range(strAddress)
      
      Set rngAddress = Range(rngAddress.Offset(intOffset, 0), rngAddress.Offset(intOffset + intRows - 1, 0))
      
      strAddress = Replace(rngAddress.Address, "$", "")
      
      ActiveSheet.ChartObjects(strChart).Activate
        
      ActiveChart.SetSourceData Source:=Range(strAddress)
      
      ActiveChart.PlotArea.Select
      
      Selection.Left = 63.66
      Selection.Height = 243.941
      Selection.Top = 32
      
      ActiveChart.FullSeriesCollection(1).Select
      ActiveChart.FullSeriesCollection(1).ApplyDataLabels
      ActiveChart.FullSeriesCollection(1).DataLabels.Select
       
      Selection.ShowCategoryName = True
      Selection.ShowPercentage = True
      Selection.Separator = "" & Chr(13) & ""
      
      ActiveChart.FullSeriesCollection(1).HasLeaderLines = True
      
      Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue
   
      CRMSliceFill
   End If
   
   Set rngChartName = rngChartName.Offset(1, 0)
Loop


End Sub

Sub CRMSliceFill()

Dim rngFill As Range

Dim varPointIndex

If strFillType = "Activity" Then
   Set rngFill = Range("CRMDA_ActivityStart").Offset(1, 0)
   Else
   Set rngFill = Range("CRMDA_CustomerStart").Offset(1, 0)
End If

Do Until rngFill = ""
   varPointIndex = Application.Match(rngFill, ActiveChart.SeriesCollection(1).XValues, 0)

   If Not IsError(varPointIndex) Then
      varPointIndex = Application.Match(rngFill, ActiveChart.SeriesCollection(1).XValues, 0)
      
      ActiveChart.SeriesCollection(1).Points(varPointIndex).Interior.Color = rngFill.Interior.Color
      Else
   End If

   Set rngFill = rngFill.Offset(1, 0)
Loop

End Sub
 
You must log in or register to reply here.

Similar threads

M
  • Question Question
Run Time Error 1004 Method 'Range' of object '_Global' failed
2
Replies
16
Views
3K
RoryA
RoryA

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top