Solved: Grouping a list in 3's or 4's depending on size?

[Simon Lloyd]

Hi all,

I would like to be able to count the amount of entries in column H and depending on the amount group them in either groups of 3 or 4, all names would be unique...so if there are 14 names in the list they would need to be grouped in to two groups of 4 and two groups of 3, if there were 19 then 4 groups of 4 and 1 group of 3 etc to a maximum 52 people, the results could appearon a seperate worksheet say pasted on to the worksheet starting with the groups of 3 (so paste a group of 3 then skip 3 rows then paste groups of 4 skip 2 rows, the row skipping is to allow seperation and manual entry of extra data). There will never be groups of 5 or more and never less than 3

The list of people has been randomly generated, there will never be groups of 5 or more and never less than 3, 12 players fits nicely in to 3 groups of 4 but 13 players would be 1 group of 4 and 3 groups of 3 and so on...etc the framework in its entirity will accommodate 52 players and at the moment i cut/copy/paste manually from the list to the right of the framework i would like this all to be handled by VBA either through a command button or when the generated list appears column H starting at H4 to H56.

the list could be typically 52 players long or less, if its less than 52 or more than 4 then grouping must take place. Lets take the scenario of 14 players, these would have to be grouped in to 2 groups of 3 and 2 groups of 4, the groups of 3 would need pasting in to the frame work first so the first group would occupy positions 1,2,3 as indicated on the framework the next group would occupy 5,6,7 and so on for all groups of 3 and then repeat for groups of 4, if there were 21 players the grouping would be 3 groups of 3 and 3 groups of 4 and so on for all permutations for up to 52 players.

I may be asking the impossible!!!

Regards,
Simon

[Bob Phillips]

Simon,

Are we supposed to be starting from the list in column H, and format as per column A, or from the list in column A.

And what grouping if there are only 5 names, or will there be a bigger minimum?

[Simon Lloyd]

Thanks for the reply Xid, sorry for tha confusion starting with a list that will be generated in to column H, the minimum would be 6 if the list is less than 6 do nothing, also if the list contains blanks ignore them......so if a list appears in column H do grouping copy and paste grouping to column A groups of 3 first, after pasting a group of 3 skip 3 rows until all groups of 3 have been pasted then groups of 4 and skip 2 rows after every paste of groups of 4.

Hope its possible!,

Regards,
Simon

[Bob Phillips]

Try this for a starter



Option Explicit

Sub Test()
Dim oWSThis As Worksheet
Dim iLastRow As Long
Dim nSkip As Long
Dim nItems As Long
Dim nBlanks As Long
Dim nGroupsOf3 As Long
Dim nGroupsOf4 As Long
Dim iProcessed As Long
Dim i As Long, j As Long

Set oWSThis = ActiveSheet

iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
i = Cells(1, "H").End(xlDown).Row
nSkip = i - 1

nItems = iLastRow - i + 1
If nItems < 6 Then

MsgBox "too few names to process"

Else

On Error Resume Next
nBlanks = Cells(i, "H").Resize(nItems).SpecialCells(xlCellTypeBlanks).Rows.Count
nGroupsOf3 = 4 - (nItems - nBlanks) Mod 4
If nGroupsOf3 = 4 Then nGroupsOf3 = 0
nGroupsOf4 = (nItems - (nGroupsOf3 * 3)) / 4

Application.DisplayAlerts = False
Worksheets("Play List").Delete
Application.DisplayAlerts = True
Worksheets.Add.Name = "Play List"
oWSThis.Activate

On Error GoTo 0

For i = i To iLastRow
If Cells(i, "H").Value <> "" Then
iProcessed = iProcessed + 1
j = j + 1
Worksheets("Play List").Cells(j, "A").Value = _
Cells(i, "H").Value
If iProcessed Mod 3 = 0 Then
If nGroupsOf3 * 3 >= iProcessed Then
j = j + 1
End If
End If
If j Mod 5 = 4 Then
j = j + 1
End If
End If
Next i

End If
End Sub

[mdmackillop]

Hi Simon,
It's all possible (well nearly!)
Here's a looping solution. Select your range of names first.


Option Explicit
Sub Groups()
Dim Chk As Long
Dim Grps As Long
Dim Fours As Long
Dim Threes As Long
Dim Cel As Range
Dim i As Long, j As Long, k As Long, Rw As Long

'Clear old data
ClearData
'Count entries
Chk = Application.WorksheetFunction.CountA(Selection)

'Get count of Threes and Fours
Grps = Chk Mod 4
Select Case Grps
Case 0
Fours = Chk \ 4
Case 1
Fours = Chk \ 4 - 2
Threes = 3
Case 2
Fours = Chk \ 4 - 1
Threes = 2
Case 3
Fours = Chk \ 4
Threes = 1
End Select

'Set start row
Rw = 4
k = 1
'Write Fours
For i = 1 To Fours
For j = 1 To 4

Do Until Selection(k) <> ""
k = k + 1
Loop
Cells(Rw, 2) = Selection(k)
k = k + 1
Rw = Rw + 1
Next j
Rw = Rw + 2
Next i
'Write Threes
For i = 1 To Threes
For j = 1 To 3
Do Until Selection(k) <> ""
k = k + 1
Loop
Cells(Rw, 2) = Selection(k)
Rw = Rw + 1
k = k + 1
Next j
Rw = Rw + 3
Next i
End Sub

Sub ClearData()
Dim Arr, a, i As Long
Arr = Array(4, 5, 6, 7)
For i = 0 To 20
For Each a In Arr
Cells(a + 6 * i, 2).ClearContents
Next
Next
End Sub

[mdmackillop]

Beaten again! :igiveup:

[Simon Lloyd]

Xid, MD thanks for the detailed responses, i have been struggling with this for ages, i tried using CASE SELECT in my code but the computation for finding 3's and 4's was beyond me!, MD your code was clear and easy for me to follow the operation of the code however it took a little longer than Xid's code to complete. So i will use Xid's code.

if i change the code or find a different solution i will post back here, even if the thread is closed!

Many thanks,
Simon

[mdmackillop]

Happy you got your solution.
Regards
MD

[Bob Phillips]

Xid, MD thanks for the detailed responses, i have been struggling with this for ages, i tried using CASE SELECT in my code but the computation for finding 3's and 4's was beyond me!, MD your code was clear and easy for me to follow the operation of the code however it took a little longer than Xid's code to complete. So i will use Xid's code.

if i change the code or find a different solution i will post back here, even if the thread is closed!

Many thanks,
Simon

Who is Xid?

[Simon Lloyd]

Please accept my apologies : pray2: .....didn't quite read :bug: the name right probably because i expected there to be a vowel!:think:

XLD thanks :thumb

[Bob Phillips]

Sounds like a Spanish Sid.

[Simon Lloyd]

Sounds like a Spanish Sid.

le agradece s? de nuevo, Simon