Horizontal and Vertical Line

iliauk

Board Regular
Joined
Jun 3, 2014
Messages
163
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:
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 Sub

Horizontal 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
 

Some videos you may like

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

iliauk

Board Regular
Joined
Jun 3, 2014
Messages
163
Hm, ended up changing some of the stuff:

Code:
Sub AddLine()
'General declarations
Dim chartname As String
Dim chartusing As Chart
Dim maxinput, mininput, i, j As Long
Dim tick As Boolean
Const strSheetName As String = "t3mp_000"
Dim arLabels As String
Dim exLabels As String
Dim lablerange As Range
Dim yarray() As Variant
Dim success As Boolean
Dim rsp As VbMsgBoxResult
Dim lininput As Variant
Set wsTest = Nothing
Set chartusing = ActiveChart


Application.DisplayAlerts = False
Application.ScreenUpdating = False


'Process range:
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


'Messagebox to determine which line to draw
rsp = MsgBox("Yes - Horizontal, No - Vertical", vbYesNoCancel, "Add Horizontal Line?")
If rsp = vbYes Then
    GoTo horizcode
ElseIf rsp = vbNo Then
    GoTo vertcode
Else
    Exit Sub
End If


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
horizcode:
lininput = InputBox("Enter y-value", "Horizontal Line")
If lininput = vbNullString Then Exit Sub
'''Get x-values'''
For Each Cell In LabelRange
    ReDim Preserve yarray(1 To counter)
        yarray(counter) = Cell
        counter = counter + 1
Next Cell
'''Get x-values'''
'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(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
For j = LBound(yarray) To UBound(yarray)
    ActiveWorkbook.Sheets(strSheetName).Cells(i, j) = yarray(j)
    ActiveWorkbook.Sheets(strSheetName).Cells(i + 1, j) = lininput
Next j


'Insert Line
With chartusing.SeriesCollection(chartusing.SeriesCollection.Count)
    .ChartType = xlXYScatterLinesNoMarkers
    .XValues = ActiveWorkbook.Sheets(strSheetName).Cells(i, LBound(yarray)).Resize(, UBound(yarray))
    .Values = ActiveWorkbook.Sheets(strSheetName).Cells(i + 1, LBound(yarray)).Resize(, UBound(yarray))
    .Format.Line.Visible = msoTrue
    .Format.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
    .MarkerStyle = -4142
End With


'Reset temp
'ActiveChart.Axes(xlCategory).AxisBetweenCategories = tick
'Need axis on tick for horizontal line
ActiveChart.Axes(xlCategory).AxisBetweenCategories = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
vertcode:
lininput = InputBox("Enter x-value", "Vertical Line")
If lininput = vbNullString Then Exit Sub
'''Get x-values'''
For Each Cell In LabelRange
    ReDim Preserve yarray(1 To counter)
        If Cell Like lininput Then
        yarray(counter) = Cell
        success = 1
        Exit For
        End If
Next Cell


If success = 0 Then
    MsgBox "x-value not found"
    Exit Sub
End If
'''Get x-values'''
'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
Exit Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,108,924
Messages
5,525,656
Members
409,658
Latest member
Yardcell

This Week's Hot Topics

Top