Extract start and end points of arrows in worksheet

[ipocca]

Hi Guys,

I am picking up from an old thread here ww.mrexcel.com/forum/<wbr>showthread.php?t=50484

I'm trying to extract data from a worksheet that has activities represented as text in cells, and dependencies between activities represented by default straight arrow shapes going from one cell to another.

so this looked promising...

For Each sShape In ActiveSheet.Shapes
Set tl = sShape.TopLeftCell
Set br = sShape.BottomRightCell

until I realised this is ambiguous depending on whether the arrow is orientated Bottom Left to Top Right or Top Left to Bottom Right. Anybody know how to extract the start and finish point (or cell) of an arrow in a worksheet please?

Any workarounds, hints, code much appreciated. A step forward would be establishing the arrow orientation.

Cheers
Ian

 

[MickG]

Hi, There are 4 Positions for a Line, "No Flip", Vertical Flip", Horizontal Flip" and "Horizontal/Vertical Flip". These Relate to similar positions of the Four Quarters of a Minute Hand on a Clock.
Depending on what the orientation is, depends How you alter the Related Cell address.
Place a Line on your sheet. Rename it "Line 5" and then run the code to see the Msgbox Top & Left Positions. Do this by repositioning the line for the 4 Orientations.
It Might give you some ideas.

[COLOR="Navy"]Sub[/COLOR] MG09Nov25
[COLOR="Navy"]Dim[/COLOR] Col1, Rw1, Col2, Rw2
[COLOR="Navy"]If[/COLOR] ActiveSheet.Shapes("Line 5").VerticalFlip And _
 Not ActiveSheet.Shapes("Line 5").HorizontalFlip [COLOR="Navy"]Then[/COLOR]
 MsgBox "V"
    [COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes("Line 5")
        Col1 = Split(.TopLeftCell.Address, "$")(1)
        Rw1 = Split(.TopLeftCell.Address, "$")(2)
        Col2 = Split(.BottomRightCell.Address, "$")(1)
        Rw2 = Split(.BottomRightCell.Address, "$")(2)
            MsgBox "Topcell " & Range(Col2 & Rw1).Address
            MsgBox& "Bottomcell " & Range(Col1 & Rw2).Address
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]ElseIf[/COLOR] ActiveSheet.Shapes("Line 5").HorizontalFlip And _
Not ActiveSheet.Shapes("Line 5").VerticalFlip [COLOR="Navy"]Then[/COLOR]
 
MsgBox "H"
[COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes("Line 5")
        Col1 = Split(.TopLeftCell.Address, "$")(1)
        Rw1 = Split(.TopLeftCell.Address, "$")(2)
        Col2 = Split(.BottomRightCell.Address, "$")(1)
        Rw2 = Split(.BottomRightCell.Address, "$")(2)
            MsgBox "Topcell " & Range(Col2 & Rw1).Address
            MsgBox& "Bottomcell " & Range(Col1 & Rw2).Address
    [COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]ElseIf[/COLOR] ActiveSheet.Shapes("Line 5").VerticalFlip And _
 ActiveSheet.Shapes("Line 5").HorizontalFlip [COLOR="Navy"]Then[/COLOR]
 MsgBox "VH"
 [COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes("Line 5")
        Col1 = Split(.TopLeftCell.Address, "$")(1)
        Rw1 = Split(.TopLeftCell.Address, "$")(2)
        Col2 = Split(.BottomRightCell.Address, "$")(1)
        Rw2 = Split(.BottomRightCell.Address, "$")(2)
            MsgBox "Topcell " & Range(Col1 & Rw1).Address
            MsgBox& "Bottomcell " & Range(Col2 & Rw2).Address
    [COLOR="Navy"]End[/COLOR] With
  [COLOR="Navy"]Else[/COLOR]
  MsgBox "No Flip"
    [COLOR="Navy"]With[/COLOR] ActiveSheet.Shapes("Line 5")
        MsgBox "Topcell " & .TopLeftCell.Address
        MsgBox "Bottomcell " & .BottomRightCell.Address
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ipocca]

Thanks Mick, I am encouraged by this. I'll work this through later this week and post the outcome for others.

 

[ipocca]

Thanks once again Mick, for the benefit of others I've adapted Mick's code to get start and finish cells irrespective of arrow orientation.


Sub MG09Nov25()
Dim Col1, Rw1, Col2, Rw2
Dim Line As Shape

Set Line = ActiveSheet.Shapes("Line 5")
MsgBox " angle = " & Line.Rotation

If ActiveSheet.Shapes("Line 5").VerticalFlip And _
Not ActiveSheet.Shapes("Line 5").HorizontalFlip Then
MsgBox "V"
With ActiveSheet.Shapes("Line 5")
Col1 = Split(.TopLeftCell.Address, "$")(1)
Rw1 = Split(.TopLeftCell.Address, "$")(2)
Col2 = Split(.BottomRightCell.Address, "$")(1)
Rw2 = Split(.BottomRightCell.Address, "$")(2)

If Line.Rotation = 0 Then
MsgBox& "Start Cell " & Range(Col1 & Rw2).Address
MsgBox "End Cell " & Range(Col2 & Rw1).Address
ElseIf Line.Rotation = 270 Then
MsgBox& "Start Cell " & Range(Col2 & Rw2).Address
MsgBox "End Cell " & Range(Col1 & Rw1).Address
ElseIf Line.Rotation = 180 Then
MsgBox& "Start Cell " & Range(Col2 & Rw1).Address
MsgBox "End Cell " & Range(Col1 & Rw2).Address
End If
End With
ElseIf ActiveSheet.Shapes("Line 5").HorizontalFlip And _
Not ActiveSheet.Shapes("Line 5").VerticalFlip Then

MsgBox "H"
With ActiveSheet.Shapes("Line 5")
Col1 = Split(.TopLeftCell.Address, "$")(1)
Rw1 = Split(.TopLeftCell.Address, "$")(2)
Col2 = Split(.BottomRightCell.Address, "$")(1)
Rw2 = Split(.BottomRightCell.Address, "$")(2)
MsgBox& "Start Cell " & Range(Col1 & Rw1).Address
MsgBox "End Cell " & Range(Col2 & Rw2).Address

End With
ElseIf ActiveSheet.Shapes("Line 5").VerticalFlip And _
ActiveSheet.Shapes("Line 5").HorizontalFlip Then
MsgBox "VH"
With ActiveSheet.Shapes("Line 5")
Col1 = Split(.TopLeftCell.Address, "$")(1)
Rw1 = Split(.TopLeftCell.Address, "$")(2)
Col2 = Split(.BottomRightCell.Address, "$")(1)
Rw2 = Split(.BottomRightCell.Address, "$")(2)
MsgBox "Start Cell " & Range(Col1 & Rw2).Address
MsgBox& "End Cell " & Range(Col2 & Rw1).Address
End With
Else
MsgBox "No Flip"
With ActiveSheet.Shapes("Line 5")

If Line.Rotation = 0 Then
MsgBox "Start Cell " & .TopLeftCell.Address
MsgBox "End Cell " & .BottomRightCell.Address
ElseIf Line.Rotation = 180 Then
MsgBox "Start Cell " & .BottomRightCell.Address
MsgBox "End Cell " & .TopLeftCell.Address
ElseIf Line.Rotation = 90 Then
Col1 = Split(.BottomRightCell.Address, "$")(1)
Rw1 = Split(.TopLeftCell.Address, "$")(2)
Col2 = Split(.TopLeftCell.Address, "$")(1)
Rw2 = Split(.BottomRightCell.Address, "$")(2)
MsgBox "Start Cell " & Range(Col1 & Rw1).Address
MsgBox "End Cell " & Range(Col2 & Rw2).Address
End If
End With
End If
End Sub

 

[MickG]

Hi, I'm pleased you 've got a result.
Regards Mick