' 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
.Activate
.Workbook.Worksheets(1).UsedRange.Clear
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%"
Else
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, _
PlotBy:=xlColumns
.Workbook.Close
End With
nxtArrayLoop:
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
motivationChrt:
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
nxtShpe:
Next shpe
Next sld
xlWB.Close
xlApp.Quit
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.