Randomize

[gibbo1715]

Here one for you

I have a list of 100 names in sheet 1 A2:E21

Want I want to do is click a button and the names be put onto sheet2 with no more than two names on a row and at least a gap of one cell between each names (i.e. no names are next to each other and names are well spaced out around the sheet).

Is this possible?????

:dunno

[mdmackillop]

Here's a bit of code to try. Create a RangeName for your data called MyNames. You can vary the spacing by playing around with the tmp function.


Sub SpreadNames()
Dim MyList(100)
m = -1
For Each cel In Range("MyNames")
m = m + 1
MyList(m) = cel
Next
Sheets("Sheet2").Select
i = Tmp
j = Tmp
For k = 0 To UBound(MyList) Step 2
i = i + Tmp
j = Tmp
Cells(i, j).Formula = MyList(k)
If k = 100 Then Exit Sub
Cells(i, j + Tmp).Formula = MyList(k + 1)
Next
End Sub

Function Tmp()
Tmp = Int(Rnd() * 3) + 2
End Function

[gibbo1715]

Thanks thats well on the way to what im after, is also possible to have only two names on the same column as well?

[Zack Barresse]

Malcolm, do we need to have another discussion about using Randomize? :think: ( ROFLMAO! :rofl ;) )

[gibbo1715]

Im confussed is there an issue with what im trying to do here?

[gibbo1715]

what about making a diamond shape with the names, say start at Cells A2 and P2 work in ward and then back out again down the rows, is that possible?

[mdmackillop]

No Gibbo, its just a dig at me!!!

A random spread over the columns is a bit more triccky, but a systematic spacing could be achieved. ie a top left to botton right diagonal distribution. But maybe some smart*** could prove me wrong!

[gibbo1715]

can you give me a clue with the systematic method then, I am learning a lot as I go here but VBA is not my language and I only started using it about a month ago so still have a lot to learn, have to admit its more powerful than i thought it was though.

I really appreciate the leg up u guys are giving me

[Zack Barresse]

(Sorry Gibbo, wasn't trying to confuse anybody. Just giving Malcolm a good ribbing - which I love to do! :yes )

[mdmackillop]

Change
J = Tmp to
J = J + Tmp for an example.

[gibbo1715]

No probs im easily confussed, especially at the moment


I appreciate all the help :)

[gibbo1715]

Many thanks but how would i get it to go in a diamond shape?

[mdmackillop]

That's OK Zack, I can take it!

So how about a function to return all the numbers from 1 to 50 randomly with no repeats.

[mdmackillop]

Try


Sub SpreadNames()
Dim MyList(100)
m = -1
For Each cel In Range("MyNames")
m = m + 1
MyList(m) = cel
Next
Sheets("Sheet2").Select
Range("A1").Select
i = 2
j = 29
m = 29
For k = 0 To 50 Step 2
i = i + 2
j = j - 1
m = m + 1
Cells(i, j).Formula = MyList(k)
If k = 100 Then Exit Sub
Cells(i, m).Formula = MyList(k + 1)
Next
For k = 50 To 100 Step 2
i = i + 2
j = j + 1
m = m - 1
Cells(i, j).Formula = MyList(k)
If k = 100 Then Exit Sub
Cells(i, m).Formula = MyList(k + 1)
Next
End Sub

[mdmackillop]

Hi Gibbo,
Your attachment is missing.

[gibbo1715]

Sorry, here it is, also deleted the previous comment in error so hope you managed to read it and the attachment explains better what im after

[mdmackillop]

Here's a double diamond with a userform for connections, based on your code.

[mdmackillop]

BTW, I think you should put forward your MyCon function as a KB entry.

[gibbo1715]

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

[gibbo1715]

I like what you ve done but still doesnt do what i need, the way the function i posted works is it looks at the list of names in row A, the names in rows b onwards are associates of the name in row A. It then looks at the associates and automatically creates the links between associates.

It seems a diamond will not work either for what im after as anything may be linked to anything and needs to be visible as per my original attachment, i guess random as possible will be best so your original solution may work best for me


I need to click the button and as it does in my original post

[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. : pray2:

[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.