VBA Line and intersect

mrmrf

New Member
Joined
Jun 3, 2019
Messages
34
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,790
Office Version
2007
Platform
Windows
Try this

Code:
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

New Member
Joined
Jun 3, 2019
Messages
34
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,790
Office Version
2007
Platform
Windows
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

New Member
Joined
Jun 3, 2019
Messages
34
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,790
Office Version
2007
Platform
Windows
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

New Member
Joined
Jun 3, 2019
Messages
34
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,790
Office Version
2007
Platform
Windows
Try this

Code:
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

New Member
Joined
Jun 3, 2019
Messages
34
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

Well-known Member
Joined
Dec 3, 2018
Messages
8,790
Office Version
2007
Platform
Windows
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:

Code:
    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.
 

Forum statistics

Threads
1,081,865
Messages
5,361,755
Members
400,655
Latest member
Mickey123

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top