VBA Line and intersect

[mrmrf]

Hi

Looking to see how I could utilise VBA code to draw a vertical line from a defined range (say cell B1=0, B2=1000) then horizontally intersect the vertical line down the page, to scale, from a value in another cell.

For example, the vertical line would cover cells A1-A20, with A1 value =0 and A20 Value = 1000 obtained from B1 and B2. The value in cell C1 could be any value from 0-1000 but for the example say 500. The VBA code would then place a horizontal line intersection at the half way point with a label of the horizontal line.

Thanks.

 

[DanteAmor]

Try this

Sub Macro10()
    Dim wL As Shape, c1 As Range, cell1 As String, cell2 As String
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim wTotal As Double, wPoint As Double, wInter As Double
    
    On Error Resume Next
    ActiveSheet.DrawingObjects("Line1").Delete
    ActiveSheet.DrawingObjects("Line2").Delete
    ActiveSheet.DrawingObjects("Line3").Delete
    On Error GoTo 0
    
    Set c1 = Range("A:A").Find(Range("B1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not c1 Is Nothing Then
        cell1 = c1.Address
        Set c1 = Range("A:A").Find(Range("B2").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c1 Is Nothing Then
            cell2 = c1.Address
                        
            x1 = Range(cell1).Left + Range(cell1).Width / 2
            y1 = Range(cell1).Top + Range(cell1).Height
            
            x2 = x1
            y2 = Range(cell2).Top
            
            wTotal = Range("B1") + Range("B2")
            wPoint = Range("C1").Value / wTotal
            wInter = (y2 + y1) * wPoint
            
            Set wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
                wL.Line.Weight = 1
                wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                wL.Name = "Line1"
        
            Set wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, wInter, x1 + 20, wInter)
                wL.Line.Weight = 1
                wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                wL.Name = "Line2"
        
            Set wL = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, x1 + 20, wInter, 100, 20)
                wL.TextFrame.Characters.Text = "Test Box"
                wL.Name = "Line3"
        
        End If
    End If
End Sub

-----
Result:

 

[mrmrf]

DanteAmor, thank you for the reply.

This is just what i needed to start my project. However i am not having any luck with the code.

I don't seem to be able to get it to run.

Any tips on what i might be missing for a novice new to VBA?

Thanks!

 

[DanteAmor]

DanteAmor, thank you for the reply.

This is just what i needed to start my project. However i am not having any luck with the code.

I don't seem to be able to get it to run.

Any tips on what i might be missing for a novice new to VBA?

Thanks!

To begin, put the data as they are in the image.

INSERT A MODULE
Press Alt-F11 to open the VBA editor. From the menu select Insert > Module. On the sheet that opens, paste the code previous.
Close the editor (press Alt-Q). From Excel, press Alt-F8 to open the macro selector, and select Macro10 and press Run.

 

[mrmrf]

Wow, thank you DanteAmor. That worked perfectly. Not sure what i was doing wrong, but i have been able to use and alter perfeclty.

One last request - trying to now put a text box between a range of values.

Say a text box to be sized between label height line and the bottom, a range of values, in the example 300-1000

 

[DanteAmor]

Wow, thank you DanteAmor. That worked perfectly. Not sure what i was doing wrong, but i have been able to use and alter perfeclty.

One last request - trying to now put a text box between a range of values.

Say a text box to be sized between label height line and the bottom, a range of values, in the example 300-1000

I did not understand, besides the textbox, do you want a second textbox?
Where do you want the second textbox?
According to the example, more or less in which cell will I be or from which cell and to which cell do you want the second textbox.

 

[mrmrf]

Thanks DanteAmor

I have attached an image of what i am trying now.

So in between the 0 and 400 intersect, place a scaled text box with data from G1 etc

Also, in your code. What part refers to where the vertical line begins? i would like lower, but not sure i understand the axis spec

Thanks

https://ibb.co/yp63yc1

 

[DanteAmor]

Try this

Sub Macro10()
    Dim wL As Shape, c1 As Range, cell1 As String, cell2 As String
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim wTotal As Double, wPoint As Double, wInter As Double
    Dim alto As Double
    
    On Error Resume Next
    ActiveSheet.DrawingObjects("Line1").Delete
    ActiveSheet.DrawingObjects("Line2").Delete
    ActiveSheet.DrawingObjects("Line3").Delete
    On Error GoTo 0
    
    Set c1 = Range("A:A").Find(Range("B1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not c1 Is Nothing Then
        cell1 = c1.Address
        Set c1 = Range("A:A").Find(Range("B2").Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not c1 Is Nothing Then
            cell2 = c1.Address
                        
            x1 = Range(cell1).Left + Range(cell1).Width / 2
            y1 = Range(cell1).Top + Range(cell1).Height
            
            x2 = x1
            y2 = Range(cell2).Top
            
            wTotal = Range("B1") + Range("B2")
            wPoint = Range("C1").Value / wTotal
            wInter = (y2 + y1) * wPoint
            
            Set wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, y1, x2, y2)
                wL.Line.Weight = 1
                wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                wL.Name = "Line1"
        
            Set wL = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, x1, wInter, x1 + 20, wInter)
                wL.Line.Weight = 1
                wL.Line.ForeColor.RGB = RGB(0, 0, 0)
                wL.Name = "Line2"
                
            alto = (wInter - y1) - 6
            Set wL = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, x1 + 3, y1 + 3, 100, alto)
                wL.TextFrame.Characters.Text = "Label"
                wL.Name = "Line3"
        
        End If
    End If
End Sub

 

[mrmrf]

Thanks DanteAmor.

That looks great. Is it possible to have the top of the text box start at a defined intersect?

For example if i use your code for intersect 500, the box goes from 0-500. But if i use your code again to intersect 1000, that box should go from 500-1000, not 0-1000.

Apologies its getting quite specific, i'm not following the code for the axis, so im googling and trial and error with no luck

 

[DanteAmor]

Thanks DanteAmor.

That looks great. Is it possible to have the top of the text box start at a defined intersect?

For example if i use your code for intersect 500, the box goes from 0-500. But if i use your code again to intersect 1000, that box should go from 500-1000, not 0-1000.

Apologies its getting quite specific, i'm not following the code for the axis, so im googling and trial and error with no luck

The code is not designed to run many times, the code is designed to run only once.
If you do it again, the previous lines are deleted:

    ActiveSheet.DrawingObjects("Line1").Delete
    ActiveSheet.DrawingObjects("Line2").Delete
    ActiveSheet.DrawingObjects("Line3").Delete

If you want another box, delete the previous lines from the macro and try again.