PDA

View Full Version : [SOLVED] Drawing lines



gibbo1715
02-04-2005, 04:46 AM
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
02-04-2005, 05:10 AM
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
02-04-2005, 05:21 AM
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
02-04-2005, 05:43 AM
Can you post an attachment so I can get a better idea of what you want to do?

gibbo1715
02-04-2005, 06:00 AM
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
02-04-2005, 07:27 AM
Think about the layout that you want and then I can write the code for you.

gibbo1715
02-04-2005, 08:29 AM
ok Jake, I ll put something together and get back to you



Thanks for your help

gibbo1715
02-04-2005, 11:00 AM
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
02-04-2005, 11:57 AM
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? :wot

gibbo1715
02-04-2005, 12:23 PM
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
02-05-2005, 12:57 AM
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
02-05-2005, 02:10 AM
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
02-05-2005, 02:36 AM
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
02-05-2005, 03:36 AM
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
02-05-2005, 03:49 AM
thanks jake, thats the first bit definately solved

Jacob Hilderbrand
02-05-2005, 04:03 AM
Is there anything else you still need to do or can we mark this one Solved?

gibbo1715
02-05-2005, 04:29 AM
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
02-05-2005, 04:56 AM
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
02-05-2005, 05:02 AM
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
02-05-2005, 05:11 AM
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

gibbo1715
02-05-2005, 05:22 AM
Ok this one works for me but seems to make everything an associate of the name in A1 regardless of if an association has been created or not

Maybe me trying to explain myself poorly as usual

The names in row A are just a list of names - if they have an associate then that associate is put in column b,c,d and so on

So the name in A1 may not be associated to the name in A2 and so on unless thier name appears in column b,c,d etc

I also noted that some of the associations created are incorrect, is this due to them all going through the name in A1?

Sorry if i havnt been clear as to what i need

Jacob Hilderbrand
02-05-2005, 05:28 AM
If you want to skip Col A then change this line.

For j = 1 To LastCol
To

For j = 2 To LastCol

gibbo1715
02-05-2005, 05:42 AM
Looking good Jake and now im starting to understand how its working it looks like it will do what i want, just one other thing, is it possible to remove the two way links as I will for example have the association in two records and only need the one link, not one each way?

Jacob Hilderbrand
02-05-2005, 05:55 AM
Try this.



Sub MyTest()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim Col As Collection
Dim LastCol As Long
Dim LastRow As Long
Dim Skip As Boolean
Set Col = New Collection
With Sheets("Main")
LastCol = .Range("IV1").End(xlToLeft).Column
For j = 2 To LastCol
LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
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
Skip = False
For k = 1 To Col.Count
If Col(k).Value = Cel1.Text & "@@@" & Cel2.Text Or _
Col(k).Value = Cel2.Text & "@@@" & Cel1.Text Then
Skip = True
Exit For
End If
Next k
If Skip = False Then
Col.Add Cel1.Text & "@@@" & Cel2.Text
MyCon Cel1, Cel2, j + 2
End If
End If
End If
End If
Next i
End If
Next j
End With
End Sub


Also note that some of the names have trailing spaces. For example you have Fred typed in as "Fred " in Column A.

gibbo1715
02-05-2005, 06:02 AM
Get an error object required at the following point


Sub MyTest()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim Col As Collection
Dim LastCol As Long
Dim LastRow As Long
Dim Skip As Boolean
Set Col = New Collection
With Sheets("Main")
LastCol = .Range("IV1").End(xlToLeft).Column
For j = 2 To LastCol
LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
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
Skip = False
For k = 1 To Col.Count
If Col(k).Value = Cel1.Text & "@@@" & Cel2.Text Or _'<<<error here
Col(k).Value = Cel2.Text & "@@@" & Cel1.Text Then
Skip = True
Exit For
End If
Next k
If Skip = False Then
Col.Add Cel1.Text & "@@@" & Cel2.Text
MyCon Cel1, Cel2, j + 2
End If
End If
End If
End If
Next i
End If
Next j
End With
End Sub

Jacob Hilderbrand
02-05-2005, 06:11 AM
Ok, there was a typo in the last bit of code. Try this.



Sub MyTest()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim Col As Collection
Dim LastCol As Long
Dim LastRow As Long
Dim Skip As Boolean
Set Col = New Collection
With Sheets("Main")
LastCol = .Range("IV1").End(xlToLeft).Column
For j = 2 To LastCol
LastRow = .Range(Cells(65536, j).Address).End(xlUp).Row
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
Skip = False
For k = 1 To Col.Count
If Col(k) = Cel1.Text & "@@@" & Cel2.Text Or _
Col(k) = Cel2.Text & "@@@" & Cel1.Text Then
Skip = True
Exit For
End If
Next k
If Skip = False Then
Col.Add Cel1.Text & "@@@" & Cel2.Text
MyCon Cel1, Cel2, j + 2
End If
End If
End If
End If
Next i
End If
Next j
End With
End Sub

gibbo1715
02-05-2005, 06:18 AM
Thanks Jake, this does work spot on, just one last question and then please mark this as solved, how do i swap it around to make associates rows instead of columns?

Jacob Hilderbrand
02-05-2005, 06:57 AM
Swap the two loops and it should work, though there may need to be some tweaking.

For j = 2 To LastCol
For i = 2 To LastRow

If it doesn't work post another attachment with the new data layout.

gibbo1715
02-05-2005, 07:06 AM
Sorry Jake tried that but didnt work


On the main page of the attached i ve put a few comments detailing what im after

Thanks again

Jacob Hilderbrand
02-05-2005, 07:27 AM
This should do what you want.


Sub MyTest()
Dim Cel1 As Range
Dim Cel2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim Col As Collection
Dim LastCol As Long
Dim LastRow As Long
Dim Skip As Boolean
For Each sh In ActiveSheet.Shapes
If Left(sh.Name, 1) = Chr(164) Then sh.Delete
Next sh
Set Col = New Collection
With Sheets("Main")
LastRow = .Range("A65536").End(xlUp).Row
For i = 1 To LastRow
LastCol = .Range("IV" & i).End(xlToLeft).Column
Set Cel1 = Cells.Find(What:=.Range(Cells(i, 1).Address).Text, _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not Cel1 Is Nothing Then
For j = 2 To LastCol
If Application.WorksheetFunction.CountIf( _
.Range("A" & i & ":" & 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
Skip = False
For k = 1 To Col.Count
If Col(k) = Cel1.Text & "@@@" & Cel2.Text Or _
Col(k) = Cel2.Text & "@@@" & Cel1.Text Then
Skip = True
Exit For
End If
Next k
If Skip = False Then
Col.Add Cel1.Text & "@@@" & Cel2.Text
MyCon Cel1, Cel2, i + 2
End If
End If
End If
End If
Next j
End If
Next i
End With
End Sub

gibbo1715
02-05-2005, 07:42 AM
Jake you make my life so much easier

I owe you my thanks (Again!!)

Jacob Hilderbrand
02-05-2005, 07:52 AM
You're Welcome :beerchug:

And thanks to Arron for the function that creates the shapes.