I have been trying really hard to fix the datatype format of the datalabels. unfortunately, nothing is working out. I want the datalabels to have a fomat of 0.00%. How can I change it?
Here's a sample from the program.
Dim OAPList As Range
Dim SingleCell As Range
Dim Counter As Integer
Set OAPList = Worksheets("Sheet2").Range("E2:E" & lw)
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.SeriesCollection(1).HasDataLabels = True
Counter = 1
With ActiveChart.SeriesCollection(1)
For Each SingleCell In OAPList
ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = SingleCell.Value
Counter = Counter + 1
Next SingleCell
.DataLabels.ShowValue = True
.DataLabels.NumberFormat = "0%"
'.DataLabels.Position = xlLabelPositionInsideEnd
.DataLabels.Format.AutoShapeType = msoShapeRectangularCallout
.DataLabels.Format.Line.Visible = msoTrue
End With
ActiveChart.SeriesCollection(2).Name = "Estimated Hours"
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
Change following line in For Each Loop:
ActiveChart.FullSeriesCollection(1).Points(Counter).DataLabel.Text = Format(SingleCell.Value, "0%")
Try maybe change this line:
'With ActiveChart.SeriesCollection(1)
With ActiveChart.FullSeriesCollection(1)
Related
Good morning.
I created a VB.NET application for Energy Measurement. All is OK, only one thing is a problem. In app, is code to create an excel table and also a chart. Table and chart are generated right, but series names in the chart are with default series names (e.g.: Series1, Series2... etc.). Only the last series has the right name what I set in code (I set all, but they are changed).
My code for the chart is:
Private Sub AddChart(Row As Integer, Columns As Integer)
xlWorkSheet = xlWorkBook.Sheets(2)
xlCharts = xlWorkSheet.ChartObjects
myChart = xlCharts.Add(0, 0, 1000, 500)
EnergyChart = myChart.Chart
xlWorkSheet = xlWorkBook.Sheets(1)
For i As Integer = 1 To Columns - 1
ColValue = ConvertNumberToString(i + 1)
SeriesName(i) = xlWorkSheet.Range(ColValue & "3").Value
chartRange = xlWorkSheet.Range("A4", ColValue & Row - 1)
EnergyChart.SetSourceData(Source:=chartRange)
Series = CType(EnergyChart.SeriesCollection(i), Excel.Series)
Series.Name = SeriesName(i)
Next
With EnergyChart
.HasTitle = True
.ChartTitle.Font.Color = Color.SeaGreen
.ChartTitle.Font.Size = 11
.ChartTitle.Font.Name = "Calibri"
.ChartTitle.Text = ReportFileName
.ChartType = Excel.XlChartType.xlLine
End With
End Sub
Could you please someone tell me why series names are changed to default? Thank you all.
SOLVED:
After code modification it's working right.
Private Sub AddChart(Row As Integer, Columns As Integer)
xlWorkSheet = xlWorkBook.Sheets(2)
xlCharts = xlWorkSheet.ChartObjects
myChart = xlCharts.Add(0, 0, 1000, 500)
EnergyChart = myChart.Chart
xlWorkSheet = xlWorkBook.Sheets(1)
For i As Integer = 1 To Columns - 1
ColValue = ConvertNumberToString(i + 1)
chartRange = xlWorkSheet.Range("A3", ColValue & Row - 1)
EnergyChart.SetSourceData(chartRange)
Series = CType(EnergyChart.SeriesCollection(1), Excel.Series)
Next
With EnergyChart
.HasTitle = True
.ChartTitle.Font.Color = Color.SeaGreen
.ChartTitle.Font.Size = 11
.ChartTitle.Font.Name = "Calibri"
.ChartTitle.Text = ReportFileName
.ChartType = Excel.XlChartType.xlLine
End With
End Sub
Chart OK
Right now I have the following code to display a line curve. The number of inputs can vary and I want the chart to clear and draw a new line curve every time the macro is run.
Sub addchart()
If ActiveSheet.ChartObjects.Count > 0 Then
ActiveSheet.ChartObjects.Delete
End If
Dim ws As Worksheet
Dim ch As chart
Dim ch1 As chart
Dim dt As Range
Dim i As Integer
i = Cells(Rows.Count, "I").End(xlUp).Row
Set ws = ActiveSheet
Set dt = Range(Cells(2, 10), Cells(i, 10))
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 = xlLine
.SeriesCollection(1).Name = "Deflection"
End With
If Application.WorksheetFunction.Min(dt) > -50 Then
With ch.Axes(xlValue)
.MinimumScale = -50
.MaximumScale = 0
End With
End If
End Sub
The chart that is printed looks something like this
I'm trying to figure out how to add labels to arbitrary points to the chart. Two labels to be specific. One is at the minimum value. And one is the value at any arbitrary point on x-axis. Both x-values are known and will be taken as inputs from two cells on the sheet. Something like this.
The style of highlighting is unimportant. Thanks for the help!
P.S. - I'm new to VBA and I'm learning everything on the go. I look up what I need to do and then try and imitate whatever examples I see online. So it's possible the existing program I've written for the chart might have unnecessary steps or is inefficient in some way. I would appreciate it if someone had any tips to offer to improve it, even though it does the job. Thanks!
Try those for first steps making chart labels:
Dim chartname as string
chartname = "enter_a_name"
ActiveSheet.Shapes.AddChart2(227, xlLine).Name = chartname
With ActiveSheet.Shapes(chartname).Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 1.5
End With
Set my_chart = ActiveSheet.ChartObjects(chartname).Chart
'Delete all Autolabels
my_chart.SetElement (msoElementDataLabelNone)
'Enter format of axis (just if you want to)
'With my_chart.Axes(xlCategory) ' axis adjustment
'.CategoryType = xlCategoryScale ' not XlCategoryType.xlAutomaticScale | XlCategoryType.xlTimeScale
'.TickLabels.NumberFormat = "DD.MM.YYYY hh:mm"
'.TickLabels.Orientation = xlUpward
'End With
cols = Array("F", "L") ' columns containing labels
For j = 1 To my_chart.SeriesCollection.Count
Set sc = my_chart.SeriesCollection(j)
For i = 2 To sc.Points.Count
sc.Points(i).ApplyDataLabels
sc.Points(i).DataLabel.Text = Range(cols(j - 1) & i + x).Value ' x= starting row containing values /labels
Next i
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, "I").End(xlUp).Row
Set ws = ActiveSheet
Set dt = Range(Cells(2, 10), Cells(i, 11)) ' Added another column with the relevant values to highlight line chart
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"
.FullSeriesCollection(1).ChartType = xlLine
.SeriesCollection(1).Name = "Deflection"
.SeriesCollection(2).ChartType = xlColumnStacked 'the second column shows up as a bar chart along with the line chart
End With
If Application.WorksheetFunction.Min(Range(Cells(2, 10), Cells(i, 10))) > -30 Then
With ch.Axes(xlValue)
.MinimumScale = -30
.MaximumScale = 0
End With
End If
End Sub
I am looking for how to super/subscript a letter/digit in a VBA string variable. I am working in excel with charts that have axes, titles and chart titles that require s-scripting. Additionally, there is a formula to go in a textbox:
Cpt = Cp0 * e^(-ket) where all the p's, t's and 0 are subscripts. The entire expression, (-ket) is superscripted with embedded subscripting for the e (the e between the k & t). Finally, all the specially formatted string variables will be copied to PowerPoint variables via clipboard/gettext.
Any help / guidance is greatly appreciated.
Pat K.
It is workaround Idea only and the code may not be useful for your purpose depending on source and destination of the data and may be treated as demo only. i have only used excel cells and Text Boxes on a sheet as destination and used PowerPoint Text Boxes as target.
The simple approach is that while picking up String from formatted cells/Text Boxes from excel to a variable, Font Subscript, Superscript information is also to be picked up in a parallel variable (here in a 2D Array). The same font information may be used while writing in PowerPoint. The demo idea have to be Modified/Converted to suit your need.
Demo Screen shot
The demo code
Sub Sscript()
Dim CellStr() As Variant
Dim Rng As Range, Cell As Range
Dim shp As Shape
Dim VarNo As Long, i As Long, j As Long, Txt As String, FntInfo As String
Set Rng = Range("C3:C7") 'Range used for collecting input data and font information for the variable
VarNo = 0
'loop used for Trial may be directly assigned to CellStr by increasing Varno by one for each cell
For Each Cell In Rng.Cells
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = Cell.Value
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If Cell.Characters(i, 1).Font.Subscript = True Then
FntInfo = FntInfo & "A"
ElseIf Cell.Characters(i, 1).Font.Superscript = True Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
Next Cell
'again loop used for Trial may be directly assigned to CellStr from Textboxes in the sheet
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
VarNo = VarNo + 1
ReDim Preserve CellStr(1 To 2, 1 To VarNo)
Txt = shp.TextFrame2.TextRange.Text
CellStr(1, VarNo) = Txt
FntInfo = ""
For i = 1 To Len(Txt)
If shp.TextFrame2.TextRange.Characters(i, 1).Font.Subscript = msoTrue Then
FntInfo = FntInfo & "A"
ElseIf shp.TextFrame2.TextRange.Characters(i, 1).Font.Superscript = msoTrue Then
FntInfo = FntInfo & "B"
Else
FntInfo = FntInfo & "C"
End If
Next i
CellStr(2, VarNo) = FntInfo
End If
Next
'Start of Trial code in excel to be deleted
For i = 1 To UBound(CellStr, 2)
ActiveSheet.Cells(i, 10).Value = CellStr(1, i)
ActiveSheet.Cells(i, 11).Value = CellStr(2, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = False
ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then ActiveSheet.Cells(i, 10).Characters(j, 1).Font.Superscript = True
Next j
Next
'End of Trial code in excel to be deleted
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Shape
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
For i = 1 To UBound(CellStr, 2)
Set Pshp = Sld.Shapes(i)
Pshp.TextFrame.TextRange.Text = CellStr(1, i)
FntInfo = CellStr(2, i)
For j = 1 To Len(FntInfo)
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = False
Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = False
If Mid(FntInfo, j, 1) = "A" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Subscript = True
If Mid(FntInfo, j, 1) = "B" Then Pshp.TextFrame.TextRange.Characters(j, 1).Font.Superscript = True
Next j
Next
End Sub
It is suggested to Add reference of Microsoft PowerPoint Object Library and thanks for asking a good question/challenge to achieve something seemingly not possible but logically possible.
Edit: another more simplistic approach (the 1st half of the String variable contains actual string and 2nd half of the variable contains Font Info) with generalized functions is also added below
Sub Sscript2()
Dim Txt As String, Var1 As String, Var2 As String
Dim Addr As String
Var1 = GetVarFont("C6") ' 1st half of the var contains actual string and 2nd half contain font Info
Var2 = GetVarFont("C7") ' 1st half of the var contains actual string and 2nd half contain font Info
'Powerpoint placement of data in powerpoint
Dim Pp As PowerPoint.Application
Dim Prs As Presentation
Dim Sld As Slide
Dim Pshp As Object
Set Pp = CreateObject("Powerpoint.application")
Pp.Visible = True
Set Prs = Pp.Presentations.Open("C:\users\user\desktop\test.pptx")
Set Sld = Prs.Slides(1)
WriteShp Sld.Shapes(8).TextFrame.TextRange, Var1
WriteShp Sld.Shapes(9).TextFrame.TextRange, Var2
End Sub
Sub WriteShp(Ptxt As TextRange, VarX As String)
Dim i As Long
Ptxt.Text = Left(VarX, Len(VarX) / 2)
For i = 1 To Len(VarX) / 2
Ptxt.Characters(i, 1).Font.Subscript = False
Ptxt.Characters(i, 1).Font.Superscript = False
If Mid(VarX, Len(VarX) / 2 + i, 1) = "A" Then Ptxt.Characters(i, 1).Font.Subscript = True
If Mid(VarX, Len(VarX) / 2 + i, 1) = "B" Then Ptxt.Characters(i, 1).Font.Superscript = True
Next
End Sub
Function GetVarFont(Addr As String) As String
Dim Txt As String, i As Long
Txt = Range(Addr).Value
GetVarFont = Txt
For i = 1 To Len(Txt)
If Range(Addr).Characters(i, 1).Font.Subscript = True Then
GetVarFont = GetVarFont & "A"
ElseIf Range(Addr).Characters(i, 1).Font.Superscript = True Then
GetVarFont = GetVarFont & "B"
Else
GetVarFont = GetVarFont & "C"
End If
Next i
End Function
I have a problem with my macro that creates chart, it works well when I step through but restarts my Excel when I run it normally. Tried various things, nothing works. It was originally part of other macro, but I isolated it to another sub, thinking it may help, but it still crashes when isolated.
Do you guys know what may be causing this?
EDIT1: There is no error information, the excel just restarts
EDIT2: The problem seems to be caused by this part of code:
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = "Liczba Dni Promocji - Wykres"
.ChartTitle.Font.Bold = True
.ChartTitle.Font.Size = 16
This is the code:
Sub StworzWykres()
Application.ScreenUpdating = False
'Application.PrintCommunication = True
Dim ws As Worksheet
Dim pt As PivotTable
Dim chrt As Chart
Dim myRng As Range
Dim i As Integer
Dim j As Integer
Set ws = ThisWorkbook.Sheets("Raport_LiczbaDniPromocji")
Set pt = ws.PivotTables("LDP_Tab1")
'delete existing charts
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
Set shp = Nothing
'ask if make a chart
Application.ScreenUpdating = True
If MsgBox("Czy chcesz utworzyć wykres Liczby Dni Promocji?", vbYesNo, "Wykres") = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
'adding the chart
'Set chrt = ws.Shapes.AddChart.Chart
Set myRng = ws.Range(Cells(19 + pt.RowRange.Rows.Count, 4), Cells(18 + 2 * (pt.RowRange.Rows.Count), 6))
myRng.Select
Set chrt = ws.Shapes.AddChart.Chart
'Set chrt = ws.ChartObjects.Add.Chart
'chrt.Activate
With chrt
'For j = .SeriesCollection.Count To 1 Step -1
' .SeriesCollection(j).Delete
'Next j
'.SetSourceData Source:=myRng, PlotBy:=xlColumns
.ChartType = xl3DColumnClustered
'.SetSourceData Source:=myRng, PlotBy:=xlColumns
.Parent.Name = "Wykres_LDP"
.DepthPercent = 400
.PlotArea.Format.ThreeD.RotationX = 0
.PlotArea.Format.ThreeD.RotationY = 110
.RightAngleAxes = True
.ChartArea.Left = ws.Range(Cells(1, 1), Cells(1, 6)).Width + 1 'ws.Cells(20 + pt.RowRange.Rows.Count, 8).Left - (ws.Columns(7).ColumnWidth / 1.25)
.ChartArea.Top = ws.Cells(18 + pt.RowRange.Rows.Count, 8).Top
.ChartArea.Height = ws.Range(Cells(19 + pt.RowRange.Rows.Count, 8), Cells(47 + pt.RowRange.Rows.Count, 8)).Height
.ChartArea.Width = 1000
.Parent.Placement = xlMove
.ChartColor = 10
.ChartGroups(1).GapWidth = 150
.SetElement (msoElementLegendBottom)
.Legend.Font.Size = 12
.Legend.Font.Bold = True
.SetElement (msoElementChartTitleAboveChart)
.ChartTitle.Text = "Liczba Dni Promocji - Wykres"
.ChartTitle.Font.Bold = True
.ChartTitle.Font.Size = 16
With .Axes(xlCategory, xlPrimary)
.TickLabels.Orientation = 60
'.TickLabels.Font.Bold = True
'.TickLabels.Font.Size = 11
End With
For j = .SeriesCollection.Count To 1 Step -1
.SeriesCollection(j).HasDataLabels = True
.SeriesCollection(j).DataLabels.Orientation = xlUpward
.SeriesCollection(j).DataLabels.Font.Bold = True
.SeriesCollection(j).DataLabels.Font.Size = 10
If j = 1 Then
.SeriesCollection(j).DataLabels.Font.ColorIndex = 32
Else
.SeriesCollection(j).DataLabels.Font.ColorIndex = 46
End If
Next j
'.SetSourceData Source:=myRng, PlotBy:=xlColumns
End With
'clear variables
Set ws = Nothing
Set pt = Nothing
Set myRng = Nothing
i = Empty
j = Empty
'Application.PrintCommunication = False
Application.ScreenUpdating = True
End Sub
Remove
.SetElement (msoElementChartTitleAboveChart)
and insert
.HasTitle = True
in the same place.
I have a chart that is composed of two main things.
The first is a loop that creates a bunch of series based on values. Each of these series is an XY Scatter with Lines. Each of these Lines is coloured based on conditions using the Vlookup function in Excel. The first thing I need to correct is the Case part because it doesn't like the first instance of G. This only occurs when I have added the second chart.
The next thing I want is to create an XY Scatter with another Range, then apply Custom Data Labels to only those points. I can change the type of Chart the Series plots by using the answer below, which has been updated.
Dim age1 As Variant
Dim age2 As Variant
Dim per1 As Variant
Dim per2 As Variant
Dim id as Variant
Dim mp as Range
Dim yd as Range
id = Range(Range("A2"), Range("A2").End(xlDown)).Value2
age1 = Range(Range("C2"), Range("C2").End(xlDown)).Value2
age2 = Range(Range("D2"), Range("D2").End(xlDown)).Value2
per1 = Range(Range("E2"), Range("E2").End(xlDown)).Value2
per2 = Range(Range("E2"), Range("E2").End(xlDown)).Value2
Set mp = Range(Range("J2"), Range("J2").End(xlDown))
Set yd= Range(Range("E2"), Range("E2").End(xlDown))
ln = UBound(id) - LBound(id) + 1
Set cht = ws.ChartObjects(1).Chart
With cht
.ChartArea.ClearContents 'Clears the chart so a new one can be created
.ChartType = xlXYScatterLines 'Defines the Chart as a Scatter with Lines
For i = 1 To ln 'First Thing that creates many series
xdata = Array(age1(i, 1), age2(i, 1))
ydata = Array(per1(i, 1), per2(i, 1))
.SeriesCollection.NewSeries
.SeriesCollection(i).XValues = xdata
.SeriesCollection(i).Values = ydata
.SeriesCollection(i).Name = id(i, 1)
Next i
'Orginal method: .ChartType = xlXYScatter
.SeriesCollection.NewSeries
.SeriesCollection(.SeriesCollection.Count).XValues = mp
.SeriesCollection(.SeriesCollection.Count).Values = yd
.SeriesCollection(.SeriesCollection.Count).Name = "Series"
'New Method
.SeriesCollection(.SeriesCollection.Count).ChartType = xlXYScatter
End With
'end of creating charts
Set drng = Range(Range("A2"), Range("B2").End(xlDown) 'For the Vlookup
With ActiveSheet
For Each xycht In .ChartObjects
For Each mysrs In xycht.Chart.SeriesCollection
mysrs.MarkerStyle = xlMarkerStyleCircle
lnum = Application.VLookup(mysrs.Name, drng, 2, 0) 'This fails the first instance with G as a Type Mismatch Error.
' Select Case lnum
' Case "G"
' lColor = RGB(255, 0, 0)
' Case "D"
' lColor = RGB(0, 255, 0)
' Case "M"
' lColor = RGB(0, 0, 255)
' Case "A"
' lColor = RGB(0, 0, 0)
' Case Else
' lColor = RGB(255, 255, 255)
' End Select
' mysrs.MarkerBackgroundColor = lColor
' mysrs.Format.Line.Visible = msoFalse
' mysrs.Format.Line.Visible = msoTrue
' mysrs.Format.Line.ForeColor.RGB = lColor
Next
Set mypts = ws.ChartObjects(1).SeriesCollection(SeriesCollection.Count).Points(1).Apply 'This fails cause it needs an Object
mypts(mypts.Count).ApplyDataLabels
With mypts(mypts.Count).DataLabel
.ShowSeriesName = False
.ShowCategoryName = False
.ShowValue = False 'I need this tonot show Values, but my own Values.
' optional parameters
.Position = xlLabelPositionAbove
.Font.Name = "Helvetica"
.Font.Size = 10
.Font.Bold = False
End With
Next
End With
Use the ChartType property of the Series object...
.SeriesCollection(.SeriesCollection.Count).ChartType = xlXYScatter