Hi all,
I have written these two macros for adding vertical and horizontal lines (respectively) to a graph and was curious whether someone could give some tips for robustness, improvement, etc.
Vertical line:
Horizontal line
I have written these two macros for adding vertical and horizontal lines (respectively) to a graph and was curious whether someone could give some tips for robustness, improvement, etc.
Vertical line:
Code:
Sub AddVline()
'Add vertical line (IK 01/10/2014)
Dim chartname As String
Dim chartusing As Chart
Dim maxinput, i As Long
Dim lininput As Variant
Dim tick As Boolean
Const strSheetName As String = "t3mp_000"
Set wsTest = Nothing
Set chartusing = ActiveChart
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' Enter x-value at which to add line
lininput = InputBox("Enter x-value", "Vertical Line")
'''Get x-values'''
Dim arLabels As String
Dim exLabels As String
Dim lablerange As Range
Dim yarray() As Variant
Dim success As Boolean
arLabels = chartusing.SeriesCollection(1).Formula
exLabels = Mid(Mid(arLabels, InStr(arLabels, ",") + 1), 1, InStr(1, Mid(arLabels, InStr(arLabels, ",") + 2), ","))
Debug.Print exLabels
Set LabelRange = Range(exLabels)
'Create corresponding array
counter = 1
success = 0
For Each Cell In LabelRange
ReDim Preserve yarray(1 To counter)
If Cell Like lininput Then
yarray(counter) = Cell
success = 1
End If
Next Cell
If success = 0 Then
MsgBox "x-value not found"
Exit Sub
End If
'''Get x-values'''
continuecode:
'Preserve various formatting
tick = ActiveChart.Axes(xlCategory).AxisBetweenCategories
'Fix the y-axis so that line cuts through
maxinput = chartusing.Axes(xlValue).MaximumScale
chartusing.Axes(xlValue).MaximumScale = maxinput
'Insert line
chartusing.SeriesCollection.NewSeries.Name = "VertLine"
'Delete legend
On Error Resume Next
chartusing.Legend.LegendEntries(chartusing.Legend.LegendEntries.Count).Delete
'Temporary store in worksheet
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
If wsTest Is Nothing Then
ActiveWorkbook.Sheets.Add.Name = strSheetName
End If
On Error GoTo 0
'Hide temp sheet
ActiveWorkbook.Sheets(strSheetName).Visible = xlSheetHidden
'Insert on next free row
i = ActiveWorkbook.Sheets(strSheetName).Range("A65536").End(xlUp).row + 1
ActiveWorkbook.Sheets(strSheetName).Range("A" & i & ":" & "B" & i).Value = yarray(LBound(yarray))
'Insert Line
With chartusing.SeriesCollection(chartusing.SeriesCollection.Count)
.ChartType = xlXYScatterLinesNoMarkers
.XValues = ActiveWorkbook.Sheets(strSheetName).Range("A" & i & ":" & "B" & i)
.Values = Array(maxinput, 0)
.Format.Line.Visible = msoTrue
.Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
.MarkerStyle = -4142
End With
'Reset temp
ActiveChart.Axes(xlCategory).AxisBetweenCategories = tick
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End SubHorizontal line
Code:
Sub AddHline()
'Add horizontal line (IK 01/10/2014)
Dim chartname As String
Dim chartusing As Chart
Dim maxinput, mininput, i As Long
Dim lininput As Long
Dim tick As Boolean
Const strSheetName As String = "t3mp_000"
Set wsTest = Nothing
Set chartusing = ActiveChart
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' Enter y-value at which to add line
lininput = InputBox("Enter y-value", "Horizontal Line")
'''Get x-values'''
Dim arLabels As String
Dim exLabels As String
Dim lablerange As Range
Dim yarray() As Variant
arLabels = chartusing.SeriesCollection(1).Formula
exLabels = Mid(Mid(arLabels, InStr(arLabels, ",") + 1), 1, InStr(1, Mid(arLabels, InStr(arLabels, ",") + 2), ","))
Debug.Print exLabels
Set LabelRange = Range(exLabels)
'Create corresponding array
counter = 1
For Each Cell In LabelRange
ReDim Preserve yarray(1 To counter)
yarray(counter) = Cell
counter = counter + 1
Next Cell
'''Get x-values'''
'Preserve various formatting
tick = chartusing.Axes(xlCategory).AxisBetweenCategories
'Extract min and max for x-axis
maxinput = yarray(UBound(yarray))
mininput = yarray(LBound(yarray))
'Insert line
chartusing.SeriesCollection.NewSeries.Name = "HorzLine"
'Delete legend
On Error Resume Next
chartusing.Legend.LegendEntries(chartusing.Legend.LegendEntries.Count).Delete
'Temporary store in worksheet
Set wsTest = ActiveWorkbook.Worksheets("t3mp_000")
If wsTest Is Nothing Then
ActiveWorkbook.Sheets.Add.Name = "t3mp_000"
End If
On Error GoTo 0
'Hide temp sheet
ActiveWorkbook.Sheets(strSheetName).Visible = xlSheetHidden
'Insert on next free row
i = ActiveWorkbook.Sheets(strSheetName).Range("A65536").End(xlUp).row + 1
ActiveWorkbook.Sheets(strSheetName).Range("A" & i & ":" & "B" & i).Value = Array(mininput, maxinput)
'Insert Line
With chartusing.SeriesCollection(chartusing.SeriesCollection.Count)
.ChartType = xlXYScatterLinesNoMarkers
.XValues = ActiveWorkbook.Sheets(strSheetName).Range("A" & i & ":" & "B" & i)
.Values = Array(lininput, lininput)
.Format.Line.Visible = msoTrue
.Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
.MarkerStyle = -4142
End With
'Reset temp
ActiveChart.Axes(xlCategory).AxisBetweenCategories = tick
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
