I'm working on a project in Excel 2016, and what needs to be done is a chart (preferably a circle) that changes each "slice's" color based on the score. The score is an integer that is pulled from the excel sheet, so it'll change based on the survey results.
Scores go 1 through 5, where 1 is red and 5 is green. I know how to conditionally format the cell itself to be the color I need, but I don't know how to do so on a chart.
I looked into VBA (via a YouTube video), but I can't get that to work either.
Here is the code I have for VBA, if anyone could help me out, or let me know how to do it at all, that would be great!
Private Sub SheetActivate(ByVal Sh As Object)
Dim cht As ChartObject
Dim i As Integer
Dim vntValues As Variant
Dim s As String
Dim mySeries As Series
For Each cht In ActiveSheet.ChartObjects
For Each mySeries In cht.Chart.SeriesCollection
If mySeries.ChartType <> xlPie Then GoTo SkipNotPie
s = Split(mySeries.Formula, ",")(2)
vntValues = mySeries.Values
For i = 1 To UBound(vntValues)
mySeries.Points(i).Interior.Color = Range(s).Cells(i).Interiror.Color
Next i
SkipNotPie:
Next mySeries
Next cht
End Sub
You have mistyping
Range(s).Cells(i).Interiror.Color
and sub procedure variable is not used in your code.
Sub test()
SheetActivate Activesheet '<~~ This will execute the following procedure.
End Sub
Private Sub SheetActivate(ByVal Sh As Object)
Dim cht As ChartObject
Dim i As Integer
Dim vntValues As Variant
Dim s As String
Dim mySeries As Series
For Each cht In Sh.ChartObjects
For Each mySeries In cht.Chart.SeriesCollection
If mySeries.ChartType <> xlPie Then GoTo SkipNotPie
s = Split(mySeries.Formula, ",")(2)
vntValues = mySeries.Values
For i = 1 To UBound(vntValues)
mySeries.Points(i).Interior.Color = Range(s).Cells(i).Interior.Color
Next i
SkipNotPie:
Next mySeries
Next cht
End Sub
If your cell color is conditionally formated then change like this
For i = 1 To UBound(vntValues)
'mySeries.Points(i).Interior.Color = Range(s).Cells(i).Interior.Color
mySeries.Points(i).Interior.Color = Range(s).Cells(i).FormatConditions(1).Interior.Color
Next i
Related
i´m using VBA in Excel to go through all Chart-Sheets and copy them to a existing PowerPoint-presentation.
Until today the program worked fine. But since today it doesn´t copy the Charts to PowerPoint anymore.
The program works like: go through all Chart-Sheets and call a Helpfunction.
The helpfunction copys the ChartArea and pastes it with:
With pptApp.ActiveWindow
.ViewType = ppViewNormal
.View.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
End With
on the PowerPoint.
But the Problem here is that the PasteSpecial doesn´t work anymore and i don´t understand why.
Thank you for your help.
Here is the full code:
'Declaring the necessary Power Point variables (are used in both subs).
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer
Sub ChartsToPowerPoint()
Dim ws As Worksheet
Dim intChNum As Integer: intChNum = 0
Dim objCh As Object
Dim ppPres As String
Dim counter As Integer
Dim rng As Range
Dim oChart As Chart
Dim zähler As Integer
Set rng = ActiveWorkbook.Sheets("Daten").Range("A1:Z200").Find("Pfad für die Powerpoint")
ppPres = rng.Offset(1, 0).Value
counter = 4
For Each ws In ActiveWorkbook.Worksheets
intChNum = intChNum + ws.ChartObjects.Count
Next ws
zähler = ActiveWorkbook.Charts.Count
'Count the embedded charts.
'For Each ws In ActiveWorkbook.Worksheets
' intChNum = intChNum + ws.ChartObjects.Count
'Next ws
'Check if there are chart (embedded or not) in the active workbook.
If intChNum + ActiveWorkbook.Charts.Count < 1 Then
MsgBox "Sorry, there are no charts to export!", vbCritical, "Ops"
Exit Sub
End If
'Open PowerPoint and create a new presentation.
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(ppPres)
'Loop through all the embedded charts in all worksheets.
For Each ws In ActiveWorkbook.Worksheets
For Each objCh In ws.ChartObjects
Call pptFormat(objCh.Chart, counter)
Next objCh
Next ws
'Loop through all the chart sheets.
For Each objCh In ActiveWorkbook.Charts
Call pptFormat(objCh, counter)
counter = counter + 1
Next objCh
'Show the power point.
pptApp.Visible = True
'Cleanup the objects.
Set pptSlide = Nothing
Set pptPres = Nothing
Set pptApp = Nothing
'Infrom the user that the macro finished.
'MsgBox "The charts were copied successfully to the new presentation!", vbInformation, "Done"
End Sub
Private Sub pptFormat(xlCh As Chart, i As Integer)
'Formats the charts/pictures and the chart titles/textboxes.
Dim chTitle As String
Dim j As Integer
Dim tempName As String
Dim oLayout As CustomLayout
Dim counter As Integer
On Error Resume Next
'Get the chart title and copy the chart area.
xlCh.ChartArea.Copy
'Count the slides and add a new one after the last slide.
pptSlideCount = pptPres.Slides.Count
'tempName = GetLayout("Layout für QGs")
counter = i
'Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, Layout:=ppLayoutVerticalTitleAndTextOverChart)
pptApp.ActivePresentation.Slides(counter).Select
'pptApp.ActivePresentation.Slides(counter).Shapes.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
With pptApp.ActiveWindow
.ViewType = ppViewNormal
.View.PasteSpecial DataType:=ppPasteOLEObject, link:=msoTrue
End With
With pptApp.ActiveWindow.Selection.ShapeRange
.LockAspectRatio = msoFalse
'Oberer Rand 1 cm unter Standardtitel
.Top = 3.92 * 28.38
'Linker Rand 1.5 cm von linkem Folienrand
.Left = 4.51 * 28.38
'Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
.Width = 24.23 * 28.38
'Bei Bedarf Höhe noch einstellen
'Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
'Die Breite verändert sich dann
.Height = 12.7 * 28.38
.Line.Visible = msoFalse
End With
End Sub
Try using this code
Function PasteChartIntoSlide(theSlide As Object) As Object
Sleep 100
On Error Resume Next
theSlide.Shapes.Paste.Select
PPT.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
End Function
Function CopyChartFromExcel(theSlide As Object, cht As Chart) As Object
cht.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
End Function
Function PositionChart(leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
Sleep 50
PPT_pres.Windows(1).Selection.ShapeRange.Left = leftPos
PPT_pres.Windows(1).Selection.ShapeRange.Top = rightPos
PPT_pres.Windows(1).Selection.ShapeRange.Width = widthPos
PPT_pres.Windows(1).Selection.ShapeRange.Height = heightPos
End Function
Function CopyPasteChartFull(Sld As Integer, cht As Chart, leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
If PPT Is Nothing Then Exit Function
If PPT_pres Is Nothing Then Exit Function
Dim mySlide As Object
Dim myShape As Object
PPT_pres.Slides(Sld).Select 'Pointless line, just lets the user see what is happening
Set mySlide = PPT_pres.Slides(Sld)
With mySlide
.Select
'copy chart
CopyChartFromExcel mySlide, cht
'Paste chart
PasteChartIntoSlide mySlide
'Position Chart
PositionChart leftPos, rightPos, widthPos, heightPos
End With
'Clear The Clipboard
Application.CutCopyMode = False
End Function
I'm trying to loop through a bar graph and make any values above 2 red. The below code is currently working but I want to get around using .Activate
Sub Works()
Dim wbk As Workbook
Dim ws As Worksheet
Dim x As Integer
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
With ws
.ChartObjects("Chart 1").Activate
For x = 1 To ActiveChart.SeriesCollection(1).Points.Count
If ActiveChart.SeriesCollection(1).Points(x).DataLabel.Caption > 2 Then
'If above 2 make Red
ActiveChart.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
'If below or equal to 2 make Blue
ActiveChart.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
End If
Next x
End With
End Sub
This was my proposed solution but I get a Run-time 438 error when I try to initiate the For loop. I'm assuming it's just a syntax error but I can't figure out how to do it without .Activate
Sub Fails()
Dim wbk As Workbook
Dim ws As Worksheet
Dim x As Integer
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
With ws.ChartObjects("Chart 1")
For x = 1 To .SeriesCollection(1).Points.Count
If .SeriesCollection(1).Points(x).DataLabel.Caption > 2 Then
'If above 2 make Red
.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
'If below or equal to 2 make Blue
.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
End If
Next x
End With
End Sub
The reason for your error already described to you by #A.S.H in the comments to your post.Series is a property of ChartObject.Chart and not ChartObject.
Try the code below, you could take advantage of VBA's chart capabilities with defining the following types of variables:
Dim ChtObj As ChartObject
Dim Ser As Series
Dim SerPoint As Point
Code
Option Explicit
Sub Fails()
Dim wbk As Workbook
Dim ws As Worksheet
Dim ChtObj As ChartObject
Dim Ser As Series
Dim SerPoint As Point
Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)
Set ChtObj = ws.ChartObjects("Chart 1") '<-- set chart object
With ChtObj
Set Ser = .Chart.SeriesCollection(1)
For Each SerPoint In Ser.Points
If SerPoint.DataLabel.Caption > 2 Then 'If above 2 make Red
SerPoint.Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else 'If below or equal to 2 make Blue
SerPoint.Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
End If
Next SerPoint
End With
End Sub
As noted in the comment by A.S.H., .Chart is the way to do it. However, you may also declare the chart as a chartObject and use the With myChart.chart in order to get the bonuses from the early binding.
Option Explicit
Sub Fails()
Dim ws As Worksheet
Dim myChart As ChartObject
Dim x As Long
Set ws = ThisWorkbook.Worksheets(1)
Set myChart = ws.ChartObjects("Chart 2")
With myChart.chart
For x = 1 To .SeriesCollection(1).Points.Count
'I have changed a bit the line below, as far as I could not achieve what were you doing...---v
If CLng(.SeriesCollection(1).Name) > 2 Then
.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
Else
.SeriesCollection(1).Points(x).Format.Fill.ForeColor.RGB = RGB(0, 0, 255)
End If
Next x
End With
End Sub
I have a pivot table and the following VBA which displays a msgbox for the first row field, but I need it to go through all row fields displaying a message box for each one, can someone point me in the right direction, I cant seem to work out how to do it
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
Set PvField = PvTable.RowFields(1)
With ws
For Each PvItem In PvField.PivotItems
MsgBox PvItem
Next
End With
End Sub
I can also get it to give me all the field headers, but not the data
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
With ws
For Each PvField In PvTable.PivotFields
MsgBox PvField
Next
End With
End Sub
This is a fairly brute-force approach, and hopefully someone will come up with something more elegant, but we can read the details of the row fields into an array of arrays, and then run through this array in reverse index order:
Option Explicit
Sub Piv()
Dim PvTable As PivotTable
Dim PvField As PivotField
Dim PvItem As PivotItem
Dim dataArray() As Variant
Dim dummyArray() As Variant
Dim i As Long
Dim j As Long
Set PvTable = ActiveSheet.PivotTables("RawDataTable")
ReDim dataArray(1 To PvTable.RowFields.Count)
ReDim dummyArray(1 To PvTable.RowFields(1).PivotItems.Count)
For i = 1 To PvTable.RowFields.Count
dataArray(i) = dummyArray
For j = 1 To PvTable.RowFields(i).PivotItems.Count
dataArray(i)(j) = PvTable.RowFields(i).PivotItems(j)
Next j
Next i
For i = 1 To UBound(dataArray(1))
For j = 1 To UBound(dataArray)
MsgBox dataArray(j)(i)
Next j
Next i
End Sub
I'm working with the following code:
Option Explicit
Sub checkboxfilter()
Dim cb As CheckBox
Dim oWS As Worksheet
Dim oWB As Workbook
Dim oPvt As PivotTable
Dim oPvtField As PivotField
Dim oPvtFilter As PivotFilter
Set cb = oWS("Control").Controls("YTD Filter")
If cb.Value = True Then
For Each oWS In ThisWorkbook.Worksheets
For Each oPvt In oWS
With oPvtField
.CurrentPage.Name = "Yes"
End With
Next oPvt
Next oWS
End If
End Sub
the goal is to toggle each pivot table in the workbook by a yer-to-date filter via checkbox. The code hits a snag under set cb= as an object variable or with not set. What am I missing here to get this control working? I'm also avoiding the use of a slicer.
Thanks.
That kind of control has it's own event and you should use it. Therefore:
go to sheet where you have your checkbox
set Design mode on developer tab on
double click on you check box to ...
...see something like Private Sub CheckBox1_Click()
inside that sub call your subroutine:
Private Sub CheckBox1_Click()
call checkboxfilter
End Sub
I was able to revise based on adjusting the type of format the set cb = as a .Checkboxes and ensuring at each pivot fielt was accurately called as #KazimierzJawor pointed out. Additionally with this type the value needed to be a 0 or 1 rather than True or False. Corrected and final code below.
Private Sub checkboxfilter()
Dim cb As CheckBox
Dim oWS As Worksheet
Dim oWB As Workbook
Dim oPvt As PivotTable
Dim oPvtField As PivotField
Dim oPvtFilter As PivotFilter
Set cb = Sheets("Control").CheckBoxes("YTD Filter")
If cb.Value = 1 Then
For Each oWS In ThisWorkbook.Worksheets
For Each oPvt In oWS.PivotTables
With oPvt.PivotFields("YTD?")
.CurrentPage = "Yes"
End With
Next oPvt
Next oWS
Else
For Each oWS In ThisWorkbook.Worksheets
For Each oPvt In oWS.PivotTables
With oPvt.PivotFields("YTD?")
.CurrentPage = "(All)"
End With
Next oPvt
Next oWS
End If
End Sub
Sub PivotFilter()
Dim pvtF As PivotField
Dim pvtI As PivotItem
Dim StartDate As Date
Dim EndDate As Date
Dim pvtIVal As String
StartDate = DateValue("Jan 1, 2018")
EndDate = Application.WorksheetFunction.EoMonth(Date, 0)
ActiveSheet.PivotTables("PivotTable1").PivotFields("Create Month").ClearAllFilters
Set pvtF = ActiveSheet.PivotTables("PivotTable1").PivotFields("Create Month")
For Each pvtI In pvtF.PivotItems
If (pvtI <> "(blank)") Then
If DateValue(pvtI) >= StartDate And DateValue(pvtI) <= EndDate Then
pvtI.Visible = True
Else
pvtI.Visible = False
End If
Else
pvtI.Visible = False
End If
Next pvtI
End Sub
I've been trying to export multiple excel charts into powerpoint but there is a catch...I'd like to export 4 charts into a single slide at a time.
I've found the following code but it needs to be modify so that 4 charts are exported into one slide, instead of a single chart per slide.
The code is below:
Thanks!
Sub PushChartsToPPT()
Dim ppt As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape
Dim cht As Chart
Dim ws As Worksheet
Dim i As Long
'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
Set pptPres = ppt.Presentations.Add
'Get a Custom Layout:
For Each pptCL In pptPres.SlideMaster.CustomLayouts
If pptCL.Name = "Title and Content" Then Exit For
Next pptCL
'Copy ALL charts embedded in EACH WorkSheet:
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To ws.ChartObjects.Count
Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
Set cht = ws.ChartObjects(i).Chart
cht.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next i
Next ws
End Sub
Try this:
For Each ws In ActiveWorkbook.Worksheets
For i = 1 To ws.ChartObjects.Count Step 4 'your count must be a multiple of four other it wouldn't work
Set pptSld = pptPres.Slides.AddSlide(pptPres.Slides.Count + 1, pptCL)
pptSld.Select
For Each pptShp In pptSld.Shapes.Placeholders
If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
Next pptShp
For j = 0 to 3
Set cht = ws.ChartObjects(i+j).Chart
cht.ChartArea.Copy
ppt.Activate
pptShp.Select
ppt.Windows(1).View.Paste
Next J
Next i