' 1. Run from PPT and open an Excel file
' 2. For each slide look for Charts -> Charts with titles -> Charts whose title include "iq_" followed by a number
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Grab values from column and store in smallArray and repeat for all "iq_'s" on the chart
' 4. Activate Powerpoint charts "Edit Data" which pulls up a non-linked Excel worksheet.
' 5. Paste table into "Edit data" in powerpoint.
' 6. Format chart numbers and color code/3d bezel Chart bars
' 7. Repeat for every slide

The above steps are a "big picture" outline of what my program does. Everything as of now works. The biggest issue here is that when I use it on files with 50+ graphs to update it tends to step over itself and skip/ignore steps, and I hope a good scrubbing of this code may fix this. Any and all help is appreciated!

For context, this is what the database and charts look like:

How the chart I want to edit looks like (Notice the title is "iq_7", giving the program a reference) chart to edit

How the database where I'm pulling in the information to populate the graph looks like (notice iq_7 is in cell G1 enter image description here

Finally, what I need the graph to look like after it has pulled in the data enter image description here

    Option Explicit

Public Sub tableArray()

    'Timer start
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    StartTime = Timer

    'Create variables
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim ShRef As Excel.Worksheet
    Dim pptPres As Object
    Dim colNumb As Long
    Dim rowNumb As Long

    Excel.Application.DisplayAlerts = False

    ' Create new excel instance and open relevant workbook
    Set xlApp = New Excel.Application
    'xlApp.Visible = True 'Make Excel visible
    Set xlWB = xlApp.Workbooks.Open("C:\Users\Andre Kunz\Desktop\Gate\Macros\graphFill\Trial\Book1.xlsx", True, False, , , , True, Notify:=False) 'Open relevant workbook
    If xlWB Is Nothing Then                      ' may not need this if statement. check later.
        MsgBox ("Error retrieving file, Check file path")
        Exit Sub
    End If

    xlApp.DisplayAlerts = False

    'Find # of iq's in workbook
    Set ShRef = xlWB.Worksheets("Sheet1")

    colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
    rowNumb = ShRef.Cells(ShRef.rows.Count, 1).End(xlUp).Row

    Dim IQRef() As String
    Dim iCol As Long
    Dim IQRngRef() As Variant

    ReDim IQRef(colNumb)
    ReDim IQRngRef(colNumb)

    ' capture IQ refs locally
    For iCol = 1 To colNumb
        Set IQRngRef(iCol) = ShRef.Range(ShRef.Cells(1, iCol), ShRef.Cells(rowNumb, iCol))
        IQRef(iCol) = ShRef.Cells(1, iCol).Value
    Next iCol

    'Make pptPres the ppt active
    Set pptPres = PowerPoint.ActivePresentation

    'Create variables for the slide loop
    Dim sld As Slide
    Dim shpe As Shape
    Dim c As Chart
    Dim cTitle As String
    Dim iq_Array As Variant
    Dim arrayLoop As Long

    For Each sld In pptPres.Slides

        'searches through shapes in the slide
        For Each shpe In sld.Shapes

            'Checks if shape is a Charts and has a Chart Title
            If Not shpe.HasChart Then GoTo nxtShpe
            If Not shpe.Chart.HasTitle Then GoTo nxtShpe

            Set c = shpe.Chart

            If c.ChartType = xlPie Then GoTo nxtShpe

            'Set cTitle as the Text in the title, then make it lowercase and trim Spaces and Enters
            cTitle = c.ChartTitle.Text
            cTitle = LCase(Replace(cTitle, " ", vbNullString))
            cTitle = Replace(Replace(Replace(cTitle, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)

            'Identify if within text there is "iq_"
            If InStr(1, cTitle, "iq_") <= 0 Then GoTo nxtShpe

            'set iq_Array as an array of the split iq's
            iq_Array = Split(cTitle, ",")

            Dim sizeSmallArray As Long
            sizeSmallArray = UBound(iq_Array) - LBound(iq_Array)

            Dim hasIQs As Boolean
            Dim checkStr As String
            Dim pCol As Long
            Dim checkOne
            Dim smallArray(0 To 1) As Variant

            checkOne = iq_Array(0)

            hasIQs = Left(checkOne, 3) = "iq_"

            ' loop for each iq_ in the array
            For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
                ' Take copy of potential ref and adjust to standard if required
                checkStr = iq_Array(arrayLoop)
                If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr

                Dim iQRefArray As Variant
                Dim iQRefString As String
                Dim checkRefStr As String
                Dim smallArrayCount As Long

                smallArrayCount = 1

                ' Look for existence of corresponding column in local copy array
                pCol = 0
                For iCol = 2 To colNumb
                    'format the numbers in the excel file to fit code needs. The full form for iq_'s in the excel database is: "iq_66_01__A_"
                    iQRefString = Left(IQRef(iCol), Len(IQRef(iCol)) - 1)
                    iQRefArray = Replace(iQRefString, "__", "_")
                    iQRefArray = Split(iQRefArray, "_")
                    checkRefStr = "iq_" & iQRefArray(1)

                    'check if "iq_#" in powerpoint is the same as "iq_#" in Excel
                    If checkStr = checkRefStr Then
                        pCol = iCol
                        Exit For
                    End If
                Next iCol

                If Not pCol > 0 Then GoTo nxtArrayLoop

                smallArray(0) = IQRngRef(1)
                smallArray(smallArrayCount) = IQRngRef(pCol)

                smallArrayCount = smallArrayCount + 1

                Dim compiledRows As Long
                compiledRows = UBound(smallArray(0)) - LBound(smallArray(0))

                Dim compiledColumns As Long
                compiledColumns = UBound(smallArray)

                Dim compiledArray As Variant
                ReDim compiledArray(compiledRows, compiledColumns)
                Dim cols As Long
                Dim rows As Long
                For cols = LBound(smallArray) To UBound(smallArray)
                    For rows = 0 To compiledRows
                        compiledArray(rows, cols) = smallArray(cols)(rows + 1, 1)
                    Next rows
                Next cols

                With c.ChartData
                    ActiveWindow.ViewType = ppViewNormal

                    Dim pasteRange As Range
                    Set pasteRange = .Workbook.Worksheets(1).Range("B2")
                    pasteRange.Resize(UBound(compiledArray) + 1, UBound(compiledArray, 2) + 1).Value2 = compiledArray

                    'Number formatting
                    If c.SeriesCollection(1).HasDataLabels Then
                        If Not shpe.Chart.ChartType = xlColumnClustered Then
                            Worksheets(1).UsedRange.NumberFormat = "0%"
                            Worksheets(1).UsedRange.NumberFormat = "0.0"
                        End If
                    End If

                    c.SetSourceData _
        Source:="= 'Sheet1'!" & Worksheets(1).Range(Worksheets(1).Cells(2, 2), Worksheets(1).Cells(UBound(compiledArray) + 2, UBound(compiledArray, 2) + 2)).Address, _

                End With
            Next arrayLoop

            'Chart Colorization
            Dim s As Series
            Dim nPoint As Long
            Dim iPoint As Long
            Dim iSeries As Long
            Dim nSeries As Long

            nSeries = c.SeriesCollection.Count

            For iSeries = 1 To nSeries

                Set s = c.SeriesCollection(iSeries)

                nPoint = s.Points.Count

                'motivation charts have no datalable but also need to be colorized. and they have more nPoints than every other chart.
                If nPoint > 20 Then GoTo motivationChrt

                If Not s.HasDataLabels Then GoTo nxtShpe
                If s.DataLabels.NumberFormat = "0%" Or s.DataLabels.NumberFormat = "0.0%" Or s.DataLabels.NumberFormat = "0.00%" Then GoTo nxtShpe


                With s.Format.ThreeD
                    .Visible = True
                    .BevelTopInset = 15
                    .BevelTopDepth = 3
                End With

                'Check each bar to see what color it needs
                For iPoint = 1 To nPoint
                    If s.Values(iPoint) >= 7.5 Then
                        s.Points(iPoint).Interior.Color = RGB(0, 176, 80)
                    ElseIf s.Values(iPoint) < 7.5 And s.Values(iPoint) >= 3.5 Then
                        s.Points(iPoint).Interior.Color = RGB(255, 192, 0)
                    ElseIf s.Values(iPoint) < 3.5 And s.Values(iPoint) > 0 Then
                        s.Points(iPoint).Interior.Color = RGB(255, 0, 0)
                    End If
                Next iPoint

            Next iSeries
        Next shpe

    Next sld


    Excel.Application.DisplayAlerts = True

    'End Timer
    SecondsElapsed = Round(Timer - StartTime, 2)
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

1 Answer 1


Option Explicit +1 For having that.

Declare your variables right before you use them. Dim SecondsElapsed As Double is declared at the very beginning, and not used until the very end. This leads to large declaration chunks like what follows. Declaring them just before they are needed makes code a lot cleaner.

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long

Be careful with any use of GoTo. There's generally a better way to set code up. If Not shpe.HasChart Then GoTo nxtShpe is jumping somewhere when the shpe variable doesn't have a chart. To know where you have to scroll down. Ensuring short methods that do one thing helps eliminate this. After scrolling to the bottom to see the label nxtShpe there Next shpe This can be simplified by taking the other 3 checks that also use GoTo nxtShpe and combine them into a single condition that's checked whether to proceed or not. This results in If isShapeApplicable(shpe, c, cTitle) Then because the logic is abstracted away in a function call and cleans up your guard clause. The 2nd and 3rd parameters outChart and outChartTitle will return their respective types for the chart because their reference is passed. Chip Pearson explains it better than I can http://www.cpearson.com/excel/byrefbyval.aspx.

Private Function isShapeApplicable(ByVal myShape As Shape, ByRef outChart As Chart, ByRef outChartTitle As String) As Boolean
    If myShape.HasChart Then
        Set outChart = shpe.Chart
        If outChart.ChartType.HasTitle And outChart.ChartType <> xlPie Then
            outChartTitle = CleanChartTitle(outChart.ChartTitle.Text)
            If InStr(outChartTitle, "iq_") > 0 Then
                isShapeApplicable = True
            End If
        End If
    End If
End Function

Private Function CleanChartTitle(ByVal chartsTitle As String) As String
    Dim temp As String
    temp = LCase(Replace(chartsTitle, " ", vbNullString))
    temp = Replace(Replace(Replace(temp, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
    CleanChartTitle = temp
End Function

Now that the top has been taken care of lets go to the bottom.

You have a comment 'Chart Colorization' and that's a good indication you can encapsulate that into a method. Make note of the fact that this is using an enumeration, Private Enum BarColor, and this will have to go up at the top in the Declarations section. I'll just terribly mess up what an Enum is. Chip again http://www.cpearson.com/excel/Enums.aspx to explain.

Private Enum BarColor
    Green = 5287936 'RGB(0, 176, 80)
    OrangeYellow = 49407 'RGB(255, 192, 0)
    Red = 255 'RGB(255, 0, 0)
End Enum

Private Sub ColorizeTheChart(ByVal myChart As Chart)
    Dim seriesCount As Long
    For seriesCount = 1 To myChart.SeriesCollection.Count
        Dim mySeries As Series
        Set mySeries = myChart.SeriesCollection(seriesCount)

        If mySeries.Points.Count <= 20 Then
            If mySeries.HasDataLabels Then
                If mySeries.DataLabels.NumberFormat <> "0%" And mySeries.DataLabels.NumberFormat <> "0.0%" And mySeries.DataLabels.NumberFormat <> "0.00%" Then
                    With mySeries.Format.ThreeD
                        .Visible = msoCTrue
                        .BevelBottomInset = 15
                        .BevelTopDepth = 3
                    End With

                    Dim seriesPoint As Long
                    For seriesPoint = 1 To mySeries.Points.Count
                        mySeries.Points(seriesPoint).Interior.Color = SetBarColor(mySeries.values(seriesPoint))
                    Next seriesPoint
                End If
            End If
        End If
    Next seriesCount
End Sub

This should get you a step in the right direction to tackle the array information in the middle. A lot of the code that's sprinkled around can likely be encapsulated in it's own Sub. With that done you'll have a great start on more reader friendly code.

Always remember to write code that is easy for the reader to understand. If it takes an hour just to figure out what it's doing there's too much going on.


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.