I am writing a program to create a new excel book with a graph/chart. This chart will have multiple series (that will vary in number) with multiple graph types, but I am having a hard time using a for loop to create the series. Here is what I have so far:
Dim Dataseries As Excel.Series = CType(chartPage.SeriesCollection(), Excel.Series)
For index As Integer = 0 To GlobVars.filenameArr.Length
Dataseries(index).Name = GlobVars.filenameArr(index)
Next index
When I try to run this code I get the error:
Excel.Series cannot be indexed because it has no default property
I think you need something like this
Dim ChartObject = CType(excelWorkSheet.ChartObjects("Diagramm 1"), ChartObject)
Dim Chart = calibrationChartObject.Chart
Dim seriesCollection = CType(calibrationChart.SeriesCollection(), SeriesCollection)
' loop to create new series
For each fileName in GlobVars.filenameArr
Dim testSerie As Excel.Series = seriesCollection.NewSeries()
'Add values and customize the serie
With testSerie
.Values = New Double() {someValue, someValue}
.XValues = New Double() {someValue, someValue}
.Border.LineStyle = XlLineStyle.xlDot
.Border.Color = Color.Red
.MarkerStyle = XlMarkerStyle.xlMarkerStyleNone
.Name = fileName
End With
Next
Don't forget to release all references to excel objects after you are done or Excel will not close. Can't test it right now, but I think it should work.
Related
When an array of Shapes is given to a subroutine By Reference, how can these Shapes be grouped, WITHOUT referring to them by their .name strings ?
The code below does not work:
Sub GroupShapes(ByRef ShapeArray() As Shape)
Dim i As Long
Dim IDs() As Variant
ReDim IDs(LBound(ShapeArray) To UBound(ShapeArray))
For i = LBound(ShapeArray) To UBound(ShapeArray)
IDs(i) = ShapeArray(i).ID 'If .ID is changed into .Name then the objects become grouped Later, but they are being referred to by their name strings
Next i
ActiveSheet.Shapes.Range(IDs).Group
End Sub
I can make the code above work, just by changing .ID to .Name, but that is referring to the shapes by their .name strings which is exactly what I am trying to avoid.
As has been noted, you can create a ShapeRange by index. The difficulty is in finding the index of your shape, which isn't the same as the ID property. Additionally, your shape may already be grouped, so it won't necessarily exist at Worksheet.Shapes level
It's possible to have nested shape groups, but I believe these have to be nested from bottom-level up. In other words, I think if you try to sub-group and already grouped shape, an error will be thrown.
I may be missing something obvious, but that suggests we can group the array by finding the Worksheet.Shapes level index of a shape that either is or contains our target shape. And the index could be found by iterating those top-level shapes until the unique ID property matches. It would then be possible to create a ShapeRange on the resulting indexes.
I wonder if something like this would work:
Private Function GroupShapes(ByRef shapeArray() As Shape) As Shape
Dim i As Long, n As Long
Dim ws As Worksheet
Dim sh As Shape
Dim obj As Object
Dim idList As Collection
Dim id As Variant
Dim idArray() As Long
'Create the list of ids for sheet level shapes.
Set idList = New Collection
For i = LBound(shapeArray) To UBound(shapeArray)
Set sh = shapeArray(i)
Do While sh.Child
Set sh = sh.ParentGroup
Loop
On Error Resume Next
idList.Add sh.id, CStr(sh.id)
On Error GoTo 0
Next
If idList.Count <= 1 Then Exit Function
'Define the sheet parent.
Set obj = shapeArray(LBound(shapeArray)).Parent
Do Until TypeOf obj Is Worksheet
Set obj = obj.Parent
Loop
Set ws = obj
'Find the indexes of the shape ids.
ReDim idArray(idList.Count - 1)
n = 0
For Each id In idList
i = 1
For Each sh In ws.Shapes
If id = sh.id Then
idArray(n) = i
Exit For
End If
i = i + 1
Next
n = n + 1
Next
'Group by index.
Set GroupShapes = ws.Shapes.Range(idArray).Group
End Function
The following test seemed to work for me:
Public Sub RunMe()
Dim shapeArray(0 To 3) As Shape
Dim g As Shape
'Create a sample array.
'Note some of these shapes are already grouped so
'wouldnt appear at Sheet.Shapes level.
Set shapeArray(0) = Sheet1.Shapes("Rectangle 1")
Set shapeArray(1) = Sheet1.Shapes("Isosceles Triangle 2")
Set shapeArray(2) = Sheet1.Shapes("Arrow: Right 4")
Set shapeArray(3) = Sheet1.Shapes("Oval 7")
'Group the array.
Set g = GroupShapes(shapeArray)
End Sub
I am trying to make a fairly easy macro to activate the next series in an already active chart. (my main macro contains all the formatting stuff).
Problem with this coding, is that i am not able to assign the current active series (already selected in the graph in excel). In a graph with n series (SeriesCollection.Count = n) I want to go from x, to x+1 and if x=n i want to go back to series 1 (so the for/next included here is not necessary if I get the macro to work as intended).
Sub NextButton_Click()
Dim cht As Chart
Set cht = ActiveChart
If cht Is Nothing Then
MsgBox "Select a chart."
Exit Sub
End If
With cht
For SrsIndx = 1 To .SeriesCollection.Count
.SeriesCollection(SrsIndx).Select
Next SrsIndx
End With
End Sub
For Simple graphs, just use PlotOrder: If you are not using a Combo Chart (i.e. not mixing Line and Bar charts, and not using the Secondary Axis), then you can just use the following code:
IIF(TypeName(Selection)="Series", Selection.PlotOrder, -1)
This will return -1 if you do not have a Series selected.
However, this is actually the order within the ChartGroup - the conditions above were for when there is only 1 ChartGroup on the Chart.
Otherwise, try using Name and a loop:
Function ActiveSeriesNumber(ThisSeries AS Series) AS Long
Dim ThisChart AS Chart, TestNumber AS Long
ActiveSeriesNumber = -1
On Error GoTo FunctionError
Set ThisChart = ThisSeries.Parent.Parent 'Object Model Is Chart.ChartGroup.Series
For TestNumber = 1 to ThisChart.SeriesCollection.Count
If ThisChart.SeriesCollection(TestNumber).Name = ThisSeries.Name THen
ActiveSeriesNumber = TestNumber
Exit Function
End If
Next TestNumber
FunctionError:
On Error GoTo -1
End Function
Use this by calling ActiveSeriesNumber(Selection)
Here's the General Idea. Step through that code and you can see each series gets selected. You'll need add some object validation as this assumes the selected object is a Series.
Sub CycleSeries()
Dim MyObject As ChartObject
Dim MyChart As Chart
Dim SerCol As SeriesCollection
Dim SelSeries As Series
Dim indexSeries As Series
Dim ChartSheet As Worksheet
Dim x As Integer
Set ChartSheet = ThisWorkbook.Sheets(1)
Set MyObject = ChartSheet.ChartObjects(1)
Set MyChart = MyObject.Chart
Set SerCol = MyChart.SeriesCollection
Set SelSeries = Excel.Application.Selection
For x = 1 To SerCol.Count
Set indexSeries = SerCol(x)
If indexSeries.Name = SelSeries.Name Then
If (x = SerCol.Count) Then
Set SelSeries = SerCol(1)
SelSeries.Select
Exit For
Else
Set SelSeries = SerCol(x + 1)
SelSeries.Select
Exit For
End If
End If
Next x
End Sub
I'm trying to do the following using vba:
I automatically gather data in Excel and want to paste it in an existing PowerPoint-Chart.
It is working fine, that's the way i do it (the paste-to-powerpoint-part):
Dim myChart As PowerPoint.Chart
Dim myChart As PowerPoint.Chart
Dim myData As PowerPoint.ChartData
Dim myWkb As Excel.Workbook
Dim myWks As Excel.Worksheet
Dim wbcd As Workbook
For chnmb = 1 To 1000
On Error Resume Next
Set myChart = ppSlide.Shapes(chnmb).Chart
'test_name = myChart.Name
If myChart.Name = "" Then Else Exit For
Next
I am doing this above (surely not the perfect way) because I don't know the Chart-Name (it is supposed to work for different Charts in different ppt-Files). After that:
Set myData = myChart.ChartData
Set myWkb = myData.Workbook
Set myWks = myWkb.Worksheets(1)
dat_area = "A1:" & Cells(1 + rowct, 1 + colct).Address(RowAbsolute:=False, ColumnAbsolute:=False)
myWks.ListObjects(1).Resize myWks.Range(dat_area)
That is the part not working.
I manage to fill data into the Chart using:
myWks.Cells(j, i).Value = Workbooks("ppt-tool.xlsm").Sheets("Acc_Data").Cells(Row + j, 1 + i).Value
(via for-next; I don't want to paste the data but fill in every field) and to later edit the Chart, but it won´t change the data-area (with the blue border around it) of the ppt-Chart.
Strangely, if I create a new Chart using
Set myChart = ppSlide.Shapes.AddChart2(297, xlBarStacked100).Chart
I manage to resize the data area (with the same resize-code), but it's not working with existing Charts. Incidentally, I don't want to link the ppt-Chart to Excel (because the Excel-Tool is used over and over again with no data saved and the ppt-Charts may have to be edited later again).
I am outputting an excel chart into powerpoint and I need to add a new data series to the Chart, I have recorded the macro to see how to do it, which it requires a range to a series collection but no luck.
Here is the full working example using access 2010 vba, in which at the end I try to add a new data series:
Option Compare Database
Public Sub CreateChart()
Dim myChart As Chart
Dim gChartData As ChartData
Dim gWorkBook As Excel.Workbook
Dim gWorkSheet As Excel.Worksheet
Dim pptApp As Object
Dim pptobj As Object
Set pptApp = CreateObject("Powerpoint.Application")
Set pptobj = pptApp.Presentation.Add
pptobj.Slides.Add 1, ppLayoutBlank
' Create the chart and set a reference to the chart data.
Set myChart = pptobj.Slides(1).Shapes.AddChart.Chart
Set gChartData = myChart.ChartData
' Set the Workbook and Worksheet references.
Set gWorkBook = gChartData.Workbook
Set gWorkSheet = gWorkBook.Worksheets(1)
' Add the data to the workbook.
gWorkSheet.ListObjects("Table1").Resize gWorkSheet.Range("A1:B5")
gWorkSheet.Range("Table1[[#Headers],[Series 1]]").Value = "Items"
gWorkSheet.Range("a2").Value = "Coffee"
gWorkSheet.Range("a3").Value = "Soda"
gWorkSheet.Range("a4").Value = "Tea"
gWorkSheet.Range("a5").Value = "Water"
gWorkSheet.Range("b2").Value = "1000"
gWorkSheet.Range("b3").Value = "2500"
gWorkSheet.Range("b4").Value = "4000"
gWorkSheet.Range("b5").Value = "3000"
' Apply styles to the chart.
With myChart
.ChartStyle = 4
.ApplyLayout 4
.ClearToMatchStyle
End With
' Add the axis title.
With myChart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Units"
End With
'Add a new data series - TYPE MISMATCH ERROR!!!
myChart.SeriesCollection.NewSeries
myChart.SeriesCollection(2).Name = "New_Series"
myChart.SeriesCollection(2).Values = gWorkSheet.Range("C2:C5") 'Range that is in the worksheet
'myChart.ApplyDataLabels
' Clean up the references.
Set gWorkSheet = Nothing
' gWorkBook.Application.Quit
Set gWorkBook = Nothing
Set gChartData = Nothing
Set myChart = Nothing
End Sub
This example is in the following link: https://msdn.microsoft.com/en-us/library/office/ff973127(v=office.14).aspx
In order to run this code is necessary to import: Visual Basic For Applications, Microsoft access Object Library, OLE Automation, Microsoft office access database engine object, Microsoft Office Object Library, Microsoft Powerpoint Object Library and Microsoft Excel Object Library. (Powerpoint object library should be imported first and then Microsoft Excel Object Library or there are reference problems)
Do you have any idea of how to add a new data series or what could be wrong with the code?
Thanks a lot in advance.
Try it this way:
With myChart.SeriesCollection.NewSeries
.name = "New_Series"
.Values = gWorkSheet.Range("C2:C5").Value2
End With
First you need to reference the newly added series and you cannot just assume that it will have index 2. This method is safer.
Second take the .Value property of the said range, to get an array of values. This fixed it. The default .Value property of the Range object is not guaranteed to work in all circumstances, i.e. when the context or container is not Excel. So it is better to always be explicit when referencing the value of a range.
How do I programatically apply a ShapeStyle to a set of Points from a single Series of a Chart using vba? It seems I need a "Shapes" object that contains only the points from the series I am trying to format?
Some information is here: http://peltiertech.com/WordPress/programming-excel-2007-2010-autoshapes-with-vba/ under the "Setting Border and Fill Styles" section
I have pseudocode but I have no idea how to create the Shapes object with only the items I want in it
' Applies desired shapestyle to a specific series of a chart
Sub ApplyShapeStyle(ch As Chart, sr As Series, ss As ShapeStyle)
' Somehow create a "Shapes" object that
' contains all the points from the series as Shape objects
Dim shps as Shapes
'pseudocode
shps.Add(<all points from series>)
shps.ShapeStyle = ss
End Sub
Like I mentioned in my comment (And I could be wrong) there is no shape property available for the DataLabel which will let you change the .ShapeStyle. However I managed to achieve what you want using a complex routine.
LOGIC
Insert a temporary shape, say a rectangle in the worksheet
Apply the .ShapeStyle to this shape
Individually set the properties of DataLabel like Fill, Border color, Border Style, Shadow etc with that from the shape.
Once done, delete the shape.
CODE
Sub Sample()
Dim myChart As ChartObject
Dim chrt As Chart
Dim shp As Shape
Dim sr As Series
Set myChart = ActiveSheet.ChartObjects("Chart 1")
Set chrt = myChart.Chart
'º·. Add a temporary Shape with desired ShapeStyle
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 100, 100, 100, 100)
shp.ShapeStyle = msoShapeStylePreset42
Set sr = chrt.SeriesCollection(1)
'º·. Fill
Dim gs As GradientStop
Dim i As Integer
If shp.Fill.BackColor.ObjectThemeColor <> msoNotThemeColor Then
sr.Format.Fill.BackColor.ObjectThemeColor = shp.Fill.BackColor.ObjectThemeColor
End If
If shp.Fill.ForeColor.ObjectThemeColor <> msoNotThemeColor Then
sr.Format.Fill.ForeColor.ObjectThemeColor = shp.Fill.ForeColor.ObjectThemeColor
End If
Select Case shp.Fill.Type
Case msoFillGradient
' Have to set the gradient first otherwise might not be able to set gradientangle
sr.Fill.TwoColorGradient shp.Fill.GradientStyle, shp.Fill.GradientVariant
sr.Format.Fill.GradientAngle = shp.Fill.GradientAngle
'Removes pre-existing gradient stops as far as possible...
Do While (sr.Format.Fill.GradientStops.Count > 2)
sr.Format.Fill.GradientStops.Delete sr.Format.Fill.GradientStops.Count
Loop
For i = 1 To shp.Fill.GradientStops.Count
Set gs = shp.Fill.GradientStops(i)
If i < 3 Then
sr.Format.Fill.GradientStops.Insert gs.Color, gs.Position, gs.Transparency, i
' ...and then removes last two stops that couldn't be removed earlier
sr.Format.Fill.GradientStops.Delete 3
Else
sr.Format.Fill.GradientStops.Insert gs.Color, gs.Position, gs.Transparency, i
End If
Next i
Case msoFillSolid
sr.Format.Fill.Solid
' NYI
Case msoFillBackground
Case msoFillMixed
Case msoFillPatterned
Case msoFillPicture
Case msoFillTextured
End Select
sr.Format.Fill.Transparency = shp.Fill.Transparency
'º·. Line
If shp.Line.Visible Then
sr.Format.Line.ForeColor = shp.Line.ForeColor
sr.Format.Line.BackColor = shp.Line.BackColor
sr.Format.Line.DashStyle = shp.Line.DashStyle
sr.Format.Line.InsetPen = shp.Line.InsetPen
sr.Format.Line.Style = shp.Line.Style
sr.Format.Line.Transparency = shp.Line.Transparency
sr.Format.Line.Weight = shp.Line.Weight
' Some formatting e.g. arrowheads not supported
End If
sr.Format.Line.Visible = shp.Line.Visible
'º·. Glow
If shp.Glow.Radius > 0 Then
sr.Format.Glow.Color = shp.Glow.Color
sr.Format.Glow.Radius = shp.Glow.Radius
sr.Format.Glow.Transparency = shp.Glow.Transparency
End If
sr.Format.Glow.Radius = shp.Glow.Radius
'º·. Shadows are a pain
' see http://stackoverflow.com/questions/10178990/turn-off-marker-shadow-on-vba-generated-excel-plots
If shp.Shadow.Visible Then
sr.Format.Shadow.Blur = shp.Shadow.Blur
sr.Format.Shadow.ForeColor = shp.Shadow.ForeColor
sr.Format.Shadow.OffsetX = shp.Shadow.OffsetX
sr.Format.Shadow.OffsetY = shp.Shadow.OffsetY
sr.Format.Shadow.Size = shp.Shadow.Size
sr.Format.Shadow.Style = shp.Shadow.Style
sr.Format.Shadow.Transparency = shp.Shadow.Transparency
sr.Format.Shadow.Visible = msoTrue
Else
' Note that this doesn't work as expected...
sr.Format.Shadow.Visible = msoFalse
' ...but this kind-of does
sr.Format.Shadow.Transparency = 1
End If
'º·. SoftEdge
sr.Format.SoftEdge.Radius = shp.SoftEdge.Radius
sr.Format.SoftEdge.Type = shp.SoftEdge.Type
'º·. 3d Effects
If shp.ThreeD.Visible Then
sr.Format.ThreeD.BevelBottomDepth = shp.ThreeD.BevelBottomDepth
sr.Format.ThreeD.BevelBottomInset = shp.ThreeD.BevelBottomInset
sr.Format.ThreeD.BevelBottomType = shp.ThreeD.BevelBottomType
sr.Format.ThreeD.BevelTopDepth = shp.ThreeD.BevelTopDepth
sr.Format.ThreeD.BevelTopInset = shp.ThreeD.BevelTopInset
sr.Format.ThreeD.BevelTopType = shp.ThreeD.BevelTopType
sr.Format.ThreeD.ContourColor = shp.ThreeD.ContourColor
sr.Format.ThreeD.ContourWidth = shp.ThreeD.ContourWidth
sr.Format.ThreeD.Depth = shp.ThreeD.Depth
sr.Format.ThreeD.ExtrusionColor = shp.ThreeD.ExtrusionColor
sr.Format.ThreeD.ExtrusionColorType = shp.ThreeD.ExtrusionColorType
sr.Format.ThreeD.FieldOfView = shp.ThreeD.FieldOfView
sr.Format.ThreeD.LightAngle = shp.ThreeD.LightAngle
sr.Format.ThreeD.Perspective = shp.ThreeD.Perspective
sr.Format.ThreeD.ProjectText = shp.ThreeD.ProjectText
sr.Format.ThreeD.RotationX = shp.ThreeD.RotationX
sr.Format.ThreeD.RotationY = shp.ThreeD.RotationY
sr.Format.ThreeD.RotationZ = shp.ThreeD.RotationZ
sr.Format.ThreeD.Z = shp.ThreeD.Z
End If
sr.Format.ThreeD.Visible = shp.ThreeD.Visible
'º·. Cleanup
shp.Delete
End Sub
SCREENSHOT
Just Setting some of the .Fill properties gives me this for msoShapeStylePreset38