I'm trying to get the code to resize width in all data labels from the charts of a worksheet but I cannot manage to do it. Here I have the code to apply a number format and I'd want to add the width property to that (it's just valid for Excel 2013):
Sub FormatAllCharts()
Dim ChtObj As ChartObject
For Each ChtObj In ActiveSheet.ChartObjects
With ChtObj.Chart
For i = 1 To .SeriesCollection.Count
With .SeriesCollection(i)
.ApplyDataLabels
.DataLabels.NumberFormat = "0,0;-0,0;;"
End With
Next
End With
Next
End Sub
This is the code for changing the width size of data labels:
ActiveChart.FullSeriesCollection(1).DataLabels.Select
ActiveChart.FullSeriesCollection(1).Points(4).DataLabel.Select
Selection.Width = 19
Here, I have eventually found a solution:
Sub FormatAllCharts()
Dim i As Long
Dim oChtObj As ChartObject
For Each oChtObj In ActiveSheet.ChartObjects
With oChtObj.Chart
For i = 1 To .SeriesCollection.Count
With .SeriesCollection(i)
.ApplyDataLabels
.DataLabels.NumberFormat = "0,0;-0,0;;"
Values_Array = .Values
For j = LBound(Values_Array, 1) To UBound(Values_Array, 1)
.Points(j).DataLabel.Width = 19
Next
End With
Next
End With
Next
End Sub
Related
I am trying to make a code for changing colour of one series to match another series but with different linestyle (eg. dashed). Please see the code that I have made. I get error messages.
Thank you
Sub lineeditor()
Dim j As Integer
Dim wsheet As Worksheet
Dim cht As ChartObject
Dim serie As Series
For Each wsheet In ThisWorkbook.Worksheets
'Looping through chart in every chartobjects
For Each cht In wsheet.ChartObjects
cht.Activate
cht.Select
'Looping through second set of 9 series. totally 18 series are in the chart
For j = 1 To 9
cht.Chart.SeriesCollection(j + 9).Select
With Selection.Format.Line
.ForeColor = cht.Chart.SeriesCollection(j).Format.Line.ForeColor
.DashStyle = msoLineDashDot
End With
Next
Next
Next
End Sub
You cannot select a worksheet object that is not on the ActiveSheet. You should, however, only select or activate objects when absolutely necessary. Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset).
Sub lineeditor()
Dim j As Integer
Dim wsheet As Worksheet
Dim cht As ChartObject
Dim serie As Series
For Each wsheet In ThisWorkbook.Worksheets
For Each cht In wsheet.ChartObjects
For j = 1 To 9
With cht.Chart.SeriesCollection(j + 9).Format.Line
.ForeColor = cht.Chart.SeriesCollection(j).Format.Line.ForeColor
.DashStyle = msoLineDashDot
End With
Next
Next
Next
End Sub
Currently, all my charts are cramped together in the same spot in the same worksheet after running my code. So to view them i have to manually drag and move them to another spot. So is there a way such that i can place all the charts in a orderly manner as shown in expected output? If it is really impossible to do something like this, i am ok with offsetting the graph for every 20 cells even though it is abit inconvenient for viewing but still i attempted to do it but fail to make it happen when i include code with current output with the offsetting code.
Current output(looks like there is 1 chart but all the charts are in the same spot)
Below is the code for my current output
Sub plotgraphs()
'Call meangraph
Call sigmagraph
End Sub
Private Sub sigmagraph()
Dim i As Long, c As Long
Dim shp As Shape
Dim Cht As chart, co As Shape
Dim rngDB As Range, rngX As Range, rngY As Range
Dim Srs As Series
Dim ws As Worksheet
Set ws = Sheets("Data")
Set rngDB = ws.Range("A1").CurrentRegion
Set rngX = rngDB.Columns(1)
Set rngY = rngDB.Columns(4)
Do While Application.CountA(rngY) > 0
Set co = Worksheets("meangraphs").Shapes.AddChart
Set Cht = co.chart
With Cht
.ChartType = xlXYScatter
'remove any data which might have been
' picked up when adding the chart
Do While .SeriesCollection.Count > 0
.SeriesCollection(1).Delete
Loop
'add the data
With .SeriesCollection.NewSeries()
.XValues = rngX.Value
.Values = rngY.Value
End With
'formatting...
With Cht.Axes(xlValue)
.MinimumScale = 0
.MaximumScale = 0.5
.TickLabels.NumberFormat = "0.00E+00"
End With
Cht.Axes(xlCategory, xlPrimary).HasTitle = True
Cht.Axes(xlValue, xlPrimary).HasTitle = True
End With
Set rngY = rngY.Offset(0, 2) 'next y values
Loop
Code for offsetting chart for every 20 cells (fail to make it happen)
Dim OutSht As Worksheet
'
Dim PlaceInRange As Range
Set OutSht = ActiveWorkbook.Sheets("sigmagraphs") '<~~ Output sheet
Set PlaceInRange = OutSht.Range("B2:J21") '<~~ Output location
'
' To place charts at a distance between them
For Each chart In Sheets("sigmagraphs").ChartObjects
' OutSht.Paste PlaceInRange
' Code below changes the range itself to something 20 rows below
Set PlaceInRange = PlaceInRange.Offset(20, 0)
Next chart
Expected output
What you are looking for is the .Left and .Top properties of the Shape containing the Chart.
For example, a macro that would setup your charts into a 2-column grid would look like this:
Sub SetupChartsIntoGrid()
Const TopAnchor As Long = 50
Const LeftAnchor As Long = 50
Const HorizontalSpacing As Long = 10
Const VerticalSpacing As Long = 10
Const ChartHeight As Long = 211
Const ChartWidth As Long = 360
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoChart Then
Dim Counter As Long
Counter = Counter + 1
With shp
.Top = TopAnchor + (WorksheetFunction.RoundUp(Counter / 2, 0) - 1) * (VerticalSpacing + ChartHeight)
.Left = LeftAnchor + ((Counter + 1) Mod 2) * (HorizontalSpacing + ChartWidth)
End With
End If
Next
End Sub
I'm trying to colour my pie chart segments, according to the cells the data is drawn from, using Excel 2016.
I pinched code from a YouTube video but this is hard to read in places (1, l & i are particularly hard to differentiate) so I'm not convinced I have it right.
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).Interior.Color
Next l
SkipNotPie:
Next mySeries
Next cht
End Sub
Update: here is a snip showing the charts - I'm trying to update the chart segments to represent the cell fill colours in the second column.
With minor adjustments, this worked fine:
Private Sub SheetActivate()
Dim cht As ChartObject
Dim i As Long
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).Interior.Color
Next i
SkipNotPie:
Next mySeries
Next cht
End Sub
Make sure you don't have Option Base 1 at the top of the module. If you do, then change
s = Split(mySeries.Formula, ",")(2)
to
s = Split(mySeries.Formula, ",")(3)
I haven't used Option Base 1 since I learned to count starting at zero.
I am trying to make some revisions to my DataLabels.
I would like the column width (Down, Up and Total) to match the size of the text. I would also like to make the data label text bolded and easier to see.
Does anyone know the best method to do this given my code and the existing chart that I have right now?
Thanks!
Sub Waterfall()
'
' Waterfall Macro
'
'
Range("A7").Select
Dim rngData As Range
Dim intCounter As Integer
Dim rngToSelect As Range
Dim srs As Series
Dim i As Long
Set rngData = ActiveCell.CurrentRegion
Set rngToSelect = Range(rngData.Cells(1, 1), rngData.Cells(rngData.Rows.Count, 1))
For intCounter = 1 To rngData.Columns.Count
If rngData.Cells(1, intCounter).Value <> "Values" Then
Set rngToSelect = Union(rngToSelect, Range(rngData.Cells(1, intCounter), rngData.Cells(rngData.Rows.Count, intCounter)))
End If
Next intCounter
rngToSelect.Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rngToSelect
ActiveChart.ChartType = xlColumnStacked
ActiveChart.ChartGroups(1).GapWidth = 75
ActiveChart.SeriesCollection("Blank").Select
Selection.Format.Fill.Visible = msoFalse
For Each srs In ActiveChart.SeriesCollection
For i = 1 To UBound(srs.Values)
srs.Points(i).HasDataLabel = srs.Values(i) > 0
Next i
Next srs
ActiveChart.SeriesCollection("Blank").DataLabels.ShowValue = False
ActiveChart.SeriesCollection("Down").Interior.Color = RGB(255, 0, 0)
ActiveChart.SeriesCollection("Up").Interior.Color = RGB(0, 204, 0)
ActiveChart.Legend.LegendEntries(3).Select
Selection.delete
'Remove Gridlines
Dim axs As Axis
For Each axs In ActiveChart.Axes
axs.HasMajorGridlines = False
axs.HasMinorGridlines = False
Next
Range("A1").Select
End Sub
In order to change your data laebls text to bold try the following command:
ActiveChart.SeriesCollection("Down").DataLabels.Font.Bold = True
This is the thing: I do have an energy model. The outcome is data (Watt) of the losses of energy by wall, floor, windows, ventilation, roof. The changing part in my model is the outside temperature. I did write a macro which changes this temperature from -10 to 10 Celcius. In a normal pie-chart this works nicely. So the temperature field changes and the values for wall, floor etc are updated in their respective fields.
But this is what I need: I want a graph (line or scatter) that will display: temperature (x-axis) and power (Watt, y-axis) for all 5 (wall, floor, etc) places where I lose energy.
How to do this? Can i (do i have to) collect the data and then at the end present it in a graph? Or can i tell excel to extend the graph with each new values when temperature is changed? At this point i can only display the actual data in the fields more or less.
I hope you understand my question and that someone can point me in the right direction.
This is the code I came up with so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim ws2 As Worksheet
Set ws2 = Sheets(2)
Dim cell As Range
' loop through temperature values given on Sheet(2)
' for now these range from -10 to 10
For Each cell In ws2.Range("A20:A40")
' update values in temperature cell
ws1.Cells.Range("D10").Value = cell.Value
' add some pause
PauseTime = 1
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next
End Sub
And a screenshot:
The orange part in "Temperaturen" is changed by the macro. Thereby all other data will be updated and displayed in the chart. The chart will only update the y-axis values at this point. I would like to loop the temperature range (and display this as well on the x-axis) and keep the former values in the chart at their respective temperatures. (I also am not able to display the x-axis range.)
(update)
Ok, I do have a XY (scatter) graph now and I can set the x axis. This is what I do have so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' set chart x axis values to user input
With ws1.ChartObjects("Chart 7").Chart
With .Axes(xlCategory)
.MinimumScale = tbu_min
.MaximumScale = tbu_max
End With
End With
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add some pause
PauseTime = 0.5
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next temp
End Sub
And that looks like:
Now I only need to update the data on the right temperature...
update 2 -
I updated my data for the xy scatter graph. I forgot to insert the "Series X Values". Now the right is displayed at the right temperature. I now only need to keep the output in view; at this moment it does refresh the graph each time.
Well, I did solve my problem. Not the way I wanted it, but I do not have time left to find another way. I now just collect all the data and draw a chart from within my macro. This is a prototype that does the trick.
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim dataSize As Integer
Dim dataCounter As Integer
Dim myChartObject As ChartObject
Dim addTotal As Boolean
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' how many datapoints are there
Dim xPoints() As Integer
' add surfaces
Dim muur() As Integer
Dim vloer() As Integer
Dim ramen() As Integer
Dim dak() As Integer
Dim ventilatie() As Integer
Dim totaal() As Integer
dataSize = Abs(tbu_max - tbu_min)
ReDim xPoints(dataSize)
ReDim muur(dataSize)
ReDim vloer(dataSize)
ReDim ramen(dataSize)
ReDim dak(dataSize)
ReDim ventilatie(dataSize)
ReDim totaal(dataSize)
' collect data
dataCounter = 0
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add x for series
xPoints(dataCounter) = temp
' add data for y series
muur(dataCounter) = ws1.Cells.Range("O24").Value
vloer(dataCounter) = ws1.Cells.Range("O47").Value
ramen(dataCounter) = ws1.Cells.Range("O61").Value
dak(dataCounter) = ws1.Cells.Range("O35").Value
ventilatie(dataCounter) = ws1.Cells.Range("O68").Value
totaal(dataCounter) = ws1.Cells.Range("O74").Value
' next
dataCounter = dataCounter + 1
Next temp
' ask to add total
If MsgBox("Wil je ook het totaal tonen in de grafiek?", vbQuestion + vbYesNo) = vbYes Then
addTotal = True
Else
addTotal = False
End If
If Not ChartExists(ws1, "buitentemperatuur") Then
' Chart does not exist, create chart
With ws1.ChartObjects.Add(Left:=200, Width:=600, Top:=200, Height:=400)
With .chart
.Parent.Name = "buitentemperatuur"
.ChartType = xlXYScatterSmooth
.Axes(xlValue).HasMajorGridlines = False
.Axes(xlCategory).Crosses = xlMinimum
.Axes(xlValue).MinimumScale = 0
.HasLegend = True
.HasTitle = True
.ChartTitle.Text = "Invloed van de buitentemperatuur"
End With
End With
End If
' Chart does exist, remove old series and update chart
ws1.ChartObjects("buitentemperatuur").Activate
For Each s In ActiveChart.SeriesCollection
s.Delete
Next s
With ws1.ChartObjects("buitentemperatuur")
With .chart
.Axes(xlValue).MaximumScaleIsAuto = True
With .SeriesCollection.NewSeries
.Name = "muur"
.XValues = xPoints
.Values = muur
End With
With .SeriesCollection.NewSeries
.Name = "vloer"
.XValues = xPoints
.Values = vloer
End With
With .SeriesCollection.NewSeries
.Name = "ramen"
.XValues = xPoints
.Values = ramen
End With
With .SeriesCollection.NewSeries
.Name = "dak"
.XValues = xPoints
.Values = dak
End With
With .SeriesCollection.NewSeries
.Name = "ventilatie"
.XValues = xPoints
.Values = ventilatie
End With
If addTotal Then
With .SeriesCollection.NewSeries
.Name = "totaal"
.XValues = xPoints
.Values = totaal
End With
End If
End With
End With
End Sub
Function ChartExists(wsTest As Worksheet, strChartName As String) As Boolean
Dim chTest As ChartObject
On Error Resume Next
Set chTest = wsTest.ChartObjects(strChartName)
On Error GoTo 0
If chTest Is Nothing Then
ChartExists = False
Else
ChartExists = True
End If
End Function