Randomize

[Aaron Blood]

I cant take the credit for that, it was given to me by Aaro Blood a VBAX regular

I made it smarter if you want to update your example.

Now it detects the position of range 1 in relation to range 2 and attaches the connectors more appropriately.

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, BegCon, EndCon, rDiff, cDiff
Dim Vert As Boolean
'test for connector positioning
Vert = False
rDiff = (Rng1.Row - Rng2.Row)
cDiff = (Rng1.Column - Rng2.Column)
If Abs(cDiff) <= 1 Then Vert = True
If Vert Then
If rDiff <= 0 Then
BegCon = 3
EndCon = 1
End If
If rDiff >= 0 Then
BegCon = 1
EndCon = 3
End If
Else
If cDiff <= 0 Then
BegCon = 4
EndCon = 2
End If
If cDiff >= 0 Then
BegCon = 2
EndCon = 4
End If
End If
'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$), BegCon
.ConnectorFormat.EndConnect ActiveSheet.Shapes(n2), EndCon
End With
End Function

[gibbo1715]

Thanks Aaron, that is really good ( And i agree should be a KB entry)

Anyone got any more ideas about my randomise question?

[mdmackillop]

Hi Gibbo,
Been attending to other things for a while.
Regarding the random display, if you have 100 items, only 2 per row, you need 100rows for a space between each; similarly for columns. I don't think this is useable as per your example. I you will always have 100 names, set up a sheet with an "x" in each cell, and I can create code to place a name in each marked cell.
Regards
MD

[gibbo1715]

Thanks for the reply, My list of names is gonna be variable and probably wont be anywhere near 100 most of the time , probably nearer 20 or 30 on average and I can max at 50 if need be.

I suppose it doesnt need to be random really either or only two on a line with a gap, just need to be able to clearly see the links between the names.

I suppose a loop through the names in the range would do, offsetting the names into the chart sheet to create a realistic spacing between the names, thinking about it as long as i have enough of a gap to easily be able to view the associations that would probably work well actually.

What do you think, could that be easily acheived?

[mdmackillop]

I think this is a workable solution.
Create a sheet called Template, enter the numbers 1 to 100 in cells in appropriate locations for the number of names that will be displayed. eg, 1 to 10 might form a rough circle, but not in number order. The code will create a new sheet "ShowLinks" based on this layout, apply the names in ascending order, and delete the remaining unused numbers.

Sub SpreadNames()
    Dim MyList(100)
    m = -1
    For Each cel In Range("MyNames")
        If cel = "" Then Exit For
        m = m + 1
        MyList(m) = cel
    Next
GetPage
For i = 1 To m + 1
        Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Activate
        ActiveCell.Formula = MyList(i - 1)
    Next
For i = m + 2 To 100
        Cells.Find(What:=i, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Activate
        ActiveCell.ClearContents
    Next
End Sub
    
Sub GetPage()
    Sheets("Template").Select
    Sheets("Template").Copy Before:=Sheets(1)
    ActiveSheet.Name = "ShowLinks"
    Range("A1").Select
End Sub

[gibbo1715]

That works great, i ll finish the project and post th finished sheet here

[gibbo1715]

Thank you to everyone for your help with this, hope others find this attachment useful too.

[mdmackillop]

Looking at your code, if you remove the

MatchCase:=True

condition from your two Find routines, the code will be tolerant of misspellings, eg Rob or rob

[gibbo1715]

will do many thanks

[Aaron Blood]

Thanks Aaron, that is really good ( And i agree should be a KB entry)

I'll post it as an example on my website...

Unfortunately, my experience here in the KB has been that my submissions get edited without my permission.