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
Related
I have a macro that is building a bubble chart and for each row in the dynamic range it is creating a new series in the bubble chart. I tested the last row calculation was finding the actual last row both manually on the worksheet and with a quick macro to find the last row and display in a message box. So the macro for building the bubble chart is finding the last row correctly. The problem is that the macro is adding in blank series anyway beyond the last row. The macro is adding 10 generic series after the last row.
Macro below:
Sub bubble()
'
' bubble Macro for bubble chart
'
Dim Lastrow As Long, ws As Worksheet, wsRD As Worksheet, wsChart As Worksheet
Dim cht As ChartObject, currRow As Integer
Dim ch As Shape, SeriesNum As Integer
On Error GoTo ExitSub
For Each ws In ActiveWorkbook.Sheets
If Left(ws.Name, 12) = "Raw Data SEA" Then
Set wsRD = ws
End If
If Left(ws.Name, 10) = "SEA bubble" Then
Set wsChart = ws
End If
Next ws
Lastrow = wsRD.Cells(Rows.Count, 1).End(xlUp).Row
Set ch = wsChart.Shapes(1)
ch.Name = "SEACht"
SeriesNum = 1
For currRow = 2 To Lastrow
ch.Chart.SeriesCollection.NewSeries
ch.Chart.FullSeriesCollection(SeriesNum).Name = wsRD.Cells(currRow, 1)
ch.Chart.FullSeriesCollection(SeriesNum).XValues = wsRD.Cells(currRow, 2)
ch.Chart.FullSeriesCollection(SeriesNum).Values = wsRD.Cells(currRow, 4)
ch.Chart.FullSeriesCollection(SeriesNum).BubbleSizes = wsRD.Cells(currRow, 3)
SeriesNum = SeriesNum + 1
Next currRow
'Format Legend
ch.Chart.PlotArea.Select
ch.Chart.SetElement (msoElementLegendBottom)
ActiveWorkbook.Save
'Format X and Y axes
ch.Chart.Axes(xlCategory).Select
ch.Chart.Axes(xlCategory).MinimumScale = 0
ch.Chart.ChartArea.Select
ch.Chart.Axes(xlValue).Select
ch.Chart.Axes(xlValue).MinimumScale = 0
Application.CommandBars("Format Object").Visible = False
ActiveWorkbook.Save
' Format datalabels
ch.Chart.ApplyDataLabels
ch.Chart.FullSeriesCollection(1).DataLabels.Select
ch.Chart.FullSeriesCollection(1).HasLeaderLines = False
Application.CommandBars("Format Object").Visible = False
ActiveWorkbook.Save
' Add charttitle
'
ch.Chart.SetElement (msoElementChartTitleAboveChart)
ch.Chart.Paste
ch.Chart.ChartTitle.Text = _
"Properties operating exp - RSF and Building Age Factors"
ActiveWorkbook.Save
ExitSub:
End Sub
Thanks in advance for any help.
Checked that the last row calc was actually finding the last row to make sure that was not the issue. Tried recording the process again to see if I missed anything. I didn't see anything that was obvious to change.
Too long for a comment and maybe not the source of your problem, but NewSeries returns the added series, so you can do this and skip the SeriesNum counter:
Dim rw as Range
For currRow = 2 To Lastrow
Set rw = wsRD.Rows(currRow)
With ch.Chart.SeriesCollection.NewSeries
.Name = rw.Cells(1)
.XValues = rw.Cells(2)
.Values = rw.Cells(4)
.BubbleSizes = rw.Cells(3)
End With
Next currRow
I have written the following code to display a basic line graph.
Sub addchart()
If ActiveSheet.ChartObjects.Count > 0 Then
ActiveSheet.ChartObjects.Delete
End If
Dim ws As Worksheet
Dim ch As chart
Dim dt As Range
Dim i As Integer
i = Cells(Rows.Count, "M").End(xlUp).Row
Set ws = ActiveSheet
Set dt = Range(Cells(2, 14), Cells(i, 14))
Set ch = ws.Shapes.AddChart2(Width:=1300, Height:=300, Left:=Range("a13").Left, Top:=Range("a13").Top).chart
With ch
.SetSourceData Source:=dt
.ChartTitle.Text = "Deflection Curve"
.ChartType = xlLineMarkers
End With
End Sub
But the trouble with this is that the range of Y axis adjusts itself according to the data automatically. I want to fix this range so that the change in the graph is noticeable.
For example, the following two graphs vary in the range of values they cover but they look basically the same because the y axis is adjusting itself. One goes from 0 to -9 and the other from 0 to -25. If I can fix the range to say 0 to -30, the difference in the two graphs would be more apparent.
With ch.Axes(xlValue)
.Minimumscale = -30
.Maximumscale = 0
End with
Relevant links:
Chart.Axes method
Axis Object
Thanks to Spencer, the following code gets the result I want
Sub addchart()
If ActiveSheet.ChartObjects.Count > 0 Then
ActiveSheet.ChartObjects.Delete
End If
Dim ws As Worksheet
Dim ch As chart
Dim dt As Range
Dim i As Integer
i = Cells(Rows.Count, "M").End(xlUp).Row
Set ws = ActiveSheet
Set dt = Range(Cells(2, 14), Cells(i, 14))
Set ch = ws.Shapes.AddChart2(Width:=1300, Height:=300, Left:=Range("a13").Left, Top:=Range("a13").Top).chart
With ch
.SetSourceData Source:=dt
.ChartTitle.Text = "Deflection Curve"
.ChartType = xlLineMarkers
End With
With ch.Axes(xlValue) 'fixing range of values
.MinimumScale = -30
.MaximumScale = 0
End With
End Sub
I have the following table:
And a macro that loops through the first section of the table (rows 6-7) in order to create the Pie-Charts on the right. My target now is to loop through all other tables automatically as well. The next one would be in row11 and create a new Pie Chart for that row, then the next table (rows 15-16) and so on. The header of each table is always red. The problem is that the length of the tables vary, meaning for example in the table1 ("Build", A5:K7) there can be 2 rows like here or 50, but each time I need one PieChart for each row.
Currently I have the following working code for Table1 ("Build" A6:K79) to create the 2 PieCharts automatically, but Im unsure how to make one loop for all tables on the sheet.
Dim rownumber As Integer
Dim LabelRange As Range
Dim ValueRange As Range
Dim Chart As ChartObject
Dim LeftIndent As Long
Dim TopIndent As Long
Dim InhaltsRangeString As String
Dim LetzteZeile As Long
'Intialpositionen für Graphen
LeftIndent = 726
TopIndent = 60
rownumber = 6 'Anfang der Buildtabelle in Reihe 6 (Spalte 1)
Set LabelRange = ThisWorkbook.Worksheets("Testplan Überblick").Range("C5, E5, G5, I5")
Set TPsheet = Worksheets("Testplan Überblick")
Set ValueRange = Union(TPsheet.Cells(rownumber, 3), TPsheet.Cells(rownumber, 5), TPsheet.Cells(rownumber, 7), TPsheet.Cells(rownumber, 9))
'Loop through table 1 which always starts at row 6 (unlike the others which have no set starting point cause the ones before can vary in length!)
For rownumber = 6 To LetzteZeileFunktion Step 1 '"LetzteZeileFunktion" gives me the long value of the last row filled in table 1
Set Chart = Sheets("Testplan Überblick").ChartObjects.Add(Left:=180, Width:=270, Top:=7, Height:=210)
With Chart
.Chart.SetSourceData Source:=ValueRange
.Chart.ChartType = xlPie
.Chart.HasTitle = True
.Chart.SetElement (msoElementChartTitleAboveChart)
.Chart.ChartTitle.Text = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
.Chart.FullSeriesCollection(1).XValues = LabelRange
.Left = LeftIndent
.Top = TopIndent
.Name = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
End With
TopIndent = TopIndent + 225
Next rownumber
End Sub
Any ideas on how to loop through all the tables even though they can all differ in length (amount of rows filled with content for charts) would be greatly appreciated!
Cheers
Use the text in one of the headers to identify the start of the data rows and a blank in column A to end. I have used "testfall qty" in column B.
Option Explicit
Sub CreateCharts()
Const DATA = "Testplan Überblick"
Const ROW_START = 5
Const POSN_LEFT = 726
Const POSN_TOP = 60
Const COL = "B"
Const HEADER = "testfall qty"
Dim wb As Workbook, ws As Worksheet
Dim rngLabel As Range, rngValue As Range
Dim iRow As Long, iLastRow As Long, count As Integer
Dim oCht As ChartObject, sColA As String, bflag As Boolean
bflag = False
Set wb = ThisWorkbook
Set ws = wb.Sheets(DATA)
' scan down the sheet
iLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
For iRow = ROW_START To iLastRow
' look for Testfall Qty as header
sColA = ws.Cells(iRow, 1)
If LCase(ws.Cells(iRow, COL)) = HEADER Then
'set ranges
Set rngLabel = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
bflag = True
ElseIf Len(sColA) > 0 And bflag Then
' create chart
Set rngValue = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
Set oCht = ws.ChartObjects.Add(Left:=180, _
Width:=270, Top:=7, Height:=210)
With oCht
.Left = POSN_LEFT
.Top = POSN_TOP + (count * 255)
.Name = sColA
With .Chart
.SetSourceData Source:=rngValue
.SeriesCollection(1).XValues = rngLabel
.ChartType = xlPie
.HasTitle = True
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Text = sColA
End With
End With
count = count + 1
Else
' end of chart data
bflag = False
End If
Next
MsgBox count & " Charts created", vbInformation
End Sub
I have a macro for creating a graph and part of it identifies and highlights the final data point like below:
This works all well and good when there's data in the final row of a column, but in some cases the final row is empty therefore no point is highlighted like so:
I was wondering if there was a way to make it highlight the last point that has actual data, so even though the last row may be empty, it highlights the last row with data.
Could the following be incorporated into my code? it finds the last data point in column B:
Dim lRow As Long
lRow = Cells(Rows.Count, 2).End(xlUp).Row
Here is my code:
With co.Chart
.FullSeriesCollection(1).ChartType = xlXYScatter
.FullSeriesCollection(1).AxisGroup = 1
.FullSeriesCollection(2).ChartType = xlLine
.FullSeriesCollection(2).AxisGroup = 1
.SetSourceData Source:=my_range
.Axes(xlCategory).TickLabels.NumberFormat = "m/yy"
'highlight final dot of data
.FullSeriesCollection(1).Points(.FullSeriesCollection(1).Points.Count).ApplyDataLabels Type:=xlShowValue
.FullSeriesCollection(1).Points(.FullSeriesCollection(1).Points.Count).MarkerSize = 7
.FullSeriesCollection(1).Points(.FullSeriesCollection(1).Points.Count).MarkerStyle = xlCircle
.FullSeriesCollection(1).Points(.FullSeriesCollection(1).Points.Count).MarkerBackgroundColorIndex = 6
.FullSeriesCollection(1).Points(.FullSeriesCollection(1).Points.Count).MarkerForegroundColorIndex = 1
.HasTitle = True
.ChartTitle.Text = t
ResolveSeriesnames co.Chart
.Location Where:=xlLocationAsObject, Name:="Graphs"
I found this code on https://peltiertech.com/label-last-point-for-excel-2007/ and made a couple adjustments which works
Sub LastPointLabel2()
Dim srs As Series
Dim iPts As Long
Dim cht As ChartObject
Dim vYVals As Variant
Dim vXVals As Variant
Set ws = ActiveSheet
If ActiveChart Is Nothing Then
MsgBox "Select a chart and try again.", vbExclamation
Else
Application.ScreenUpdating = False
For Each cht In ws.ChartObjects
Set srs = cht.Chart.SeriesCollection(1)
With srs
vYVals = .Values
'vXVals = .XValues
' clear existing labels
.HasDataLabels = False
For iPts = .Points.Count To 1 Step -1
If Not IsEmpty(vYVals(iPts)) Then
' add label
srs.Points(iPts).ApplyDataLabels _
ShowSeriesName:=False, _
ShowCategoryName:=False, ShowValue:=True, _
AutoText:=True, LegendKey:=False
Exit For
End If
Next
End With
Next
' legend is now unnecessary
Application.ScreenUpdating = True
End If
End Sub
59.30 15 16 17
1 1,162,912,036.90 1,248,737,016.99 1,306,573,912.08
2 245,665,383.94 261,416,880.69 276,613,283.05
3 393,313,441.29 379,169,039.15 418,680,492.19
4 13,920,572.74 14,464,854.92 15,120,474.58
5 54,501,581.55 56,319,351.21 58,832,588.24
6 15,165,376.28 11,694,942.56 10,809,661.03
7 194,397,643.30 170,427,013.85 182,567,862.46
8 15,165,376.28 11,694,942.56 10,809,661.03
9 2,079,876,036.00 2,142,229,099.38 2,269,198,273.62
3% 6%
There are 7 tables like the above data in one excel tab in different area.I want to create a stacked column chart for each table. I wrote a code to create. Just want to know is that possiable to use loop to solve this problem? Code attached.
Sub FormatChartNIX()
'PURPOSE: Create a chart (chart dimensions are not required)
Dim rng As Range
Dim cht As Object
Dim ser As Series
Dim tmpCHR As ChartObject
'Chart1
'Your data range for the chart
Set rng = ActiveSheet.Range("B8:E17")
'Create a chart
Set cht = ActiveSheet.Shapes.AddChart
'Give chart some data
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
'Determine the chart type
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(1).Top = .Range("C24").Top
.ChartObjects(1).Left = .Range("C24").Left
End With
ActiveSheet.ChartObjects(1).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("c1")
'Chart2
Set rng = ActiveSheet.Range("G8:J17")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(2).Top = .Range("H24").Top
.ChartObjects(2).Left = .Range("H24").Left
End With
ActiveSheet.ChartObjects(2).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("h1")
'Chart3
Set rng = ActiveSheet.Range("L8:o17")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(3).Top = .Range("M24").Top
.ChartObjects(3).Left = .Range("M24").Left
End With
ActiveSheet.ChartObjects(3).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("h1")
'Chart4
Set rng = ActiveSheet.Range("B82:E91")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(4).Top = .Range("C51").Top
.ChartObjects(4).Left = .Range("C51").Left
End With
ActiveSheet.ChartObjects(4).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("c75")
'Chart5
Set rng = ActiveSheet.Range("G82:J91")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(5).Top = .Range("H51").Top
.ChartObjects(5).Left = .Range("H51").Left
End With
ActiveSheet.ChartObjects(5).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("h75")
'Chart6
Set rng = ActiveSheet.Range("L82:o91")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(6).Top = .Range("M51").Top
.ChartObjects(6).Left = .Range("M51").Left
End With
ActiveSheet.ChartObjects(6).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("m75")
'Chart7
Set rng = ActiveSheet.Range("Q82:T91")
Set cht = ActiveSheet.Shapes.AddChart
cht.chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.chart.ChartType = xlColumnStacked
With ActiveSheet
.ChartObjects(7).Top = .Range("R51").Top
.ChartObjects(7).Left = .Range("R51").Left
End With
ActiveSheet.ChartObjects(7).Activate
ActiveChart.Axes(xlValue).Select
Selection.delete
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = ActiveSheet.Range("r75")
End Sub
Using named ranges and some arrays you can loop through it.
First, create named ranges for the ranges for each chart.
I added a small table in the spreadsheet and named each one the text in the first cell of the range (i.e., Chart1,... Chart7). The other ranges each go in the next cell, so the range named "Chart 1" is 4 cells.
(I also used the same ranges and cells that you did in your code above)
Chart1 B8:E17 C24 C1
Chart2 G8:J17 H24 H1
Chart3 L8:O17 M24 H1
Chart4 B82:E91 C51 C75
Chart5 G82:J91 H51 H75
Chart6 L82:O91 M51 R75
Chart7 Q82:T91 R51 R75
Sub FormatChartNIX_Modified()
Dim rng As Range
Dim cht As Object
Dim ser As Series
Dim tmpCHR As ChartObject
Dim MyArray(1 To 7, 0 To 3) As String
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
'Set Values - possibly with named ranges
Dim vArray() As Variant
Dim strNamedRange As String
strNamedRange = "Chart" & i
Set rng = Worksheets("Sheet1").Range(strNamedRange)
vArray = rng
Dim j As Integer
For j = LBound(MyArray, 2) To UBound(MyArray, 2)
MyArray(i, j) = vArray(1, j + 1)
Debug.Print MyArray(i, j)
Next j
Next i
For i = LBound(MyArray) To UBound(MyArray)
With ActiveSheet
Set rng = .Range(MyArray(i, 1)) '1 represents the data range
Set cht = .Shapes.AddChart
cht.Chart.SetSourceData Source:=rng, PlotBy:=xlRows
cht.Chart.ChartType = xlColumnStacked
.ChartObjects(i).Top = .Range(MyArray(i, 2)).Top '0 represents the chart name
.ChartObjects(i).Left = .Range(MyArray(i, 2)).Left '2 represents the cell identifying the chart location
.ChartObjects(i).Activate
With ActiveChart
.Axes(xlValue).Select
.Axes(xlValue).Delete
.HasTitle = True
.ChartTitle.Text = ActiveSheet.Range(MyArray(i, 3)).Text '3 represents the cell where the title text is located
End With
End With
Next i
End Sub
Do that, run the sub and it will create 7 charts as described in the table - using a loop.