Drawing lines

[gibbo1715]

Can anyone tell be if it is possible using vba to draw a line between two cells.

For example if i need to link Range("A2") to Range("F4") using a ActiveSheet.Shapes.AddLine command maybe?

The cell references will change so I need it to know where the cells are and draw the line between the cells i tell it to

Many Thanks

[Jacob Hilderbrand]

Well this is an interesting request. And of course VBA can easily deliver.

Option Explicit
 
Sub DrawLines()
Dim TopX            As Double
    Dim LeftX           As Long
    Dim Ln              As Shape
    Dim a               As Double
    Dim b               As Double
    Dim Cel1            As Range
    Dim Cel2            As Range
Set Cel1 = Range("A12")
    Set Cel2 = Range("F4")
TopX = Cel1.Top
    LeftX = Cel1.Left
    a = Abs(Cel2.Offset(0, 1).Left - Cel1.Left)
    b = Abs(Cel1.Top - Cel2.Offset(1, 0).Top)
    Set Ln = ActiveSheet.Shapes.AddLine(1, 1, 1, 1)
Ln.Width = a
    Ln.Height = b
    Ln.Top = TopX
    Ln.Left = LeftX
End Sub

You can use the Application.InputBox or a RefEdit Control to get the cell addresses.

Note that this works if the first cell is above and to the left of the second cell. To account for other possibilities we would need to add some more code.

[gibbo1715]

Thanks Jake,

just to try and clarify for you.

I have a number of people in a spreadsheet one row per person(This list is dynamic) and I name any associates they have by adding the names across the row. I need to work out in the spreadsheet is associated with who graphically. I figured the best way would be to use vba to put the names into a circle (Never more than about 30) and then draw a line between them if they are associated unless you can think (And you probably can) of an easier way.

Many Thanks

[Jacob Hilderbrand]

Can you post an attachment so I can get a better idea of what you want to do?

[gibbo1715]

sorry jake havnt made one yet, just figuring out what i want

I just need to have a list of names and then visually see who knows who if that helps

[Jacob Hilderbrand]

Think about the layout that you want and then I can write the code for you.

[gibbo1715]

ok Jake, I ll put something together and get back to you



Thanks for your help

[gibbo1715]

ok have a look at the attached to see what im trying to acheive, hope it makes it all abit clearer and once again thanks for your help

[Aaron Blood]

Interesting topic, I put something together to help you guys along...

I viewed it slightly differently. Instead of trying to position a line, my idea is to just draw the circles (or rounded rectangles) around each cell and then use a connector between the two objects.

I built a function that will draw the circles and connect them given two range references. Kinda neat because it allows you to easily draw circles and connect cells or WHOLE RANGES of cells without doing any tricky math.

Sub MyTest() 
MyCon [B2:B3], [E3], 10, 1
MyCon [B2], [E6], 10, 2
MyCon [B2], [E7], 10, 3
MyCon [B6], [E2], 4, 4
MyCon [B6], [E8], 4, 5
End Sub
 
Function MyCon(Rng1 As Range, Rng2 As Range, Optional Color As Integer, Optional x As Double)
Dim MyShape As Shape, n1$, n2$, n3$
Dim L, T, W, H
If IsEmpty(x) Then x = 0
If IsEmpty(Color) Then Color = 10 'red
'Draw rounded rectangle object around Rng1
With Rng1
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n1$ = Chr(164) & Rng1.Address(False, False) & ":" & x
With MyShape
.Name = n1$
End With
Set Shape2 = ActiveSheet.Shapes(n1$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'Draw rounded rectangle object around Rng2
With Rng2
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n2$ = Chr(164) & Rng2.Address(False, False) & ":" & x
With MyShape
.Name = n2$
End With
Set Shape2 = ActiveSheet.Shapes(n2$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'connect the shapes with a line
Set MyShape = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L, T, W, H)
n3$ = n1$ & "-" & n2$
With MyShape
.Name = n3$
.Line.ForeColor.SchemeColor = Color
.Line.DashStyle = msoLineDash
.ConnectorFormat.BeginConnect ActiveSheet.Shapes(n1$), 4
.ConnectorFormat.EndConnect ActiveSheet.Shapes(n2), 2
End With
End Function
 
'You can use this macro to delete all the MyCon shape objects. 
Sub MyCon_Clear()
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 1) = Chr(164) Then sh.Delete
Next sh
End Sub

The variable inputs for the MyCon function are pretty simple.
Rng1: cell or range reference 1
Rng2: cell or range reference 2
Color: the color you want to use, the default is 10 (red)
x: If you need to circle a cell or range ref more than once, you need this value to increment. By default the value is 0 but you can feed it whatever you like. It's just a way to add some differentiation to the name of the shape objects as they're created so it doesn't raise an error. Of course, I assume there's no need to worry about Rng1 and Rng2 being the same range.

Now, in place of my test macro, you need to focus your attention on developing logic to build an array of relationships that can be fed to the MyCon function. Who knows... maybe even a function that returns a found range object would be helpful for this?

[gibbo1715]

Aaron, that is absolutely great but the logic is a bit over my head at the moment so any help will be much appreciated

[gibbo1715]

ok can anyone help me with this? Aaron has posed some great code above with the macro below to run the formula

Sub MyTest()
MyCon [B2:B3], [E3], 10, 1
    MyCon [B2], [E6], 10, 2
    MyCon [B2], [E7], 10, 3
    MyCon [B6], [E2], 4, 4
    MyCon [B6], [E8], 4, 5
End Sub

Im still trying to sort my associates but im gonna have to break it down one stage at a time or im never gonna figure this one out

can anyone tell me how to set this test macro up so i can ref a start cell from an input box and a finish cell from an input box and then press a button to establish a link on a new sheet?

[Jacob Hilderbrand]

can anyone tell me how to set this test macro up so i can ref a start cell from an input box and a finish cell from an input box and then press a button to establish a link on a new sheet?

Try this.

Option Explicit
 
Sub Macro1()
Dim Prompt          As String
Dim Title           As String
Dim StartCel        As Range
Dim EndCel          As Range
Prompt = "Select the first cell"
    Title = "Range Input"
    Set StartCel = Application.InputBox(Prompt, Title, , , , , , 8)
Prompt = "Select the second cell"
    Set EndCel = Application.InputBox(Prompt, Title, , , , , , 8)
End Sub

[gibbo1715]

Thanks Jake that does work fine if there are no links already on the cell, any idea how to link to the same cell muliple times?

Attached a spreadsheet example

[Jacob Hilderbrand]

Try this.

Sub MyTest()
Dim Prompt          As String
    Dim Title           As String
    Dim startrange      As Range
    Dim endrange        As Range
    Dim Cel1            As Range
    Dim Cel2            As Range
Prompt = "Select the initial range"
Title = "Range Input"
Set startrange = Application.InputBox(Prompt, Title, , , , , , 8)
Prompt = "Select the final range"
Set endrange = Application.InputBox(Prompt, Title, , , , , , 8)
For Each Cel1 In startrange
For Each Cel2 In endrange
MyCon Cel1, Cel2
Next
Next
End Sub
 
Function MyCon(Rng1 As Range, Rng2 As Range, Optional Color As Integer, Optional x As Double)
Dim MyShape As Shape, n1$, n2$, n3$
Dim L, T, W, H
If IsEmpty(x) Then x = 0
If IsEmpty(Color) Then Color = 10 'red
'Draw rounded rectangle object around Rng1
With Rng1
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n1$ = Chr(164) & Rng1.Address(False, False) & ":" & x
On Error Resume Next
With MyShape
.Name = n1$
End With
If Err <> 0 Then
MyShape.Delete
End If
On Error GoTo 0
Set Shape2 = ActiveSheet.Shapes(n1$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'Draw rounded rectangle object around Rng2
With Rng2
L = .Left
T = .Top
W = .Width
H = .Height
End With
Set MyShape = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, W, H)
n2$ = Chr(164) & Rng2.Address(False, False) & ":" & x
On Error Resume Next
With MyShape
.Name = n2$
End With
If Err <> 0 Then
MyShape.Delete
End If
On Error GoTo 0
Set Shape2 = ActiveSheet.Shapes(n2$)
With Shape2
.Fill.Visible = False
.Line.ForeColor.SchemeColor = Color
End With
'connect the shapes with a line
Set MyShape = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, L, T, W, H)
n3$ = n1$ & "-" & n2$
With MyShape
.Name = n3$
.Line.ForeColor.SchemeColor = Color
.Line.DashStyle = msoLineDash
.ConnectorFormat.BeginConnect ActiveSheet.Shapes(n1$), 4
.ConnectorFormat.EndConnect ActiveSheet.Shapes(n2), 2
End With
End Function
 
'You can use this macro to delete all the MyCon shape objects.
Sub MyCon_Clear()
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 1) = Chr(164) Then sh.Delete
Next sh
End Sub

[gibbo1715]

thanks jake, thats the first bit definately solved

[Jacob Hilderbrand]

Is there anything else you still need to do or can we mark this one Solved?

[gibbo1715]

Still need to figure out the associations bit

i.e i have a list on names in A1:A20 on sheet main then A2:A20 lists the associates of the name in cell A1 B2:B20 lists the associates of the name in cell B1 and so on. ( See the attached example, i need to be able to click the button and draw the links of who is associated to who on the chart sheet.

[Jacob Hilderbrand]

Try this macro.

Sub MyTest()
Dim Cel1            As Range
Dim Cel2            As Range
Dim i               As Long
Dim j               As Long
Dim LastCol         As Long
Dim LastRow         As Long
With Sheets("Main")
        LastRow = .Range("A65536").End(xlUp).Row
        LastCol = .Range("IV1").End(xlToLeft).Column
        For j = 1 To LastCol
            Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
                LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            For i = 2 To LastRow
                If Application.WorksheetFunction.CountIf( _
                .Range(Cells(2, j).Address & ":" & Cells(i, j).Address), _
                    .Range(Cells(i, j).Address).Text) = 1 _
                    And .Range(Cells(i, j).Address).Text <> "" Then
                    Set Cel2 = Cells.Find(What:=.Range(Cells(i, j).Address).Text, _
                    LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                    If Not Cel2 Is Nothing Then
                        If Cel1.Address <> Cel2.Address Then
                            MyCon Cel1, Cel2, j + 2
                        End If
                    End If
                End If
            Next i
        Next j
    End With
End Sub

[gibbo1715]

Jake that will do exactly what i want but at the moment gives an error see below

Sub Test2()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim LastCol As Long
Dim LastRow As Long
With Sheets("Main")
LastRow = .Range("A65536").End(xlUp).Row
LastCol = .Range("IV1").End(xlToLeft).Column
For j = 1 To LastCol
Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
For i = 2 To LastRow
If Application.WorksheetFunction.CountIf( _
.Range(Cells(2, j).Address & ":" & Cells(i, j).Address), _
.Range(Cells(i, j).Address).Text) = 1 _
And .Range(Cells(i, j).Address).Text <> "" Then
Set Cel2 = Cells.Find(What:=.Range(Cells(i, j).Address).Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not Cel2 Is Nothing Then
If Cel1.Address <> Cel2.Address Then '<< Error here object variable not set
MyCon Cel1, Cel2, j + 2
End If
End If
End If
Next i
Next j
End With

It also links the name in A1 to everything even if there is no association created

[Jacob Hilderbrand]

Try this.

Sub MyTest()
Dim Cel1            As Range
    Dim Cel2            As Range
    Dim i               As Long
    Dim j               As Long
    Dim LastCol         As Long
    Dim LastRow         As Long
With Sheets("Main")
        LastRow = .Range("A65536").End(xlUp).Row
        LastCol = .Range("IV1").End(xlToLeft).Column
        For j = 1 To LastCol
            Set Cel1 = Cells.Find(What:=.Range(Cells(1, j).Address).Text, _
            LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not Cel1 Is Nothing Then
                For i = 2 To LastRow
                    If Application.WorksheetFunction.CountIf( _
                        .Range(Cells(2, j).Address & ":" & Cells(i, j).Address), _
                        .Range(Cells(i, j).Address).Text) = 1 _
                        And .Range(Cells(i, j).Address).Text <> "" Then
                        Set Cel2 = Cells.Find(What:=.Range(Cells(i, j).Address).Text, _
                        LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
                        If Not Cel2 Is Nothing Then
                            If Cel1.Address <> Cel2.Address Then
                                MyCon Cel1, Cel2, j + 2
                            End If
                        End If
                    End If
                Next i
            End If
        Next j
    End With
End Sub