golf 4somes

[Lowggy]

I want to be able to take as many as 80 golf couples that are spouses and have individual handicaps and make 4somes that will have as close as possible the same total handicap.

included is code that some what works but does not do exactly as I want as stated above.

[SamT]

Do you want this in Word or in Excel?

[Lowggy]

Do you want this in Word or in Excel?

excel VBA code is how it was attempted so I would like to stick to VBA

[Paul_Hossler]

It'd be helpful if you provided a XLSM with sample data and your macro

[Lowggy]

I am going to include two files, the first one called 20 couples and 40 others is a file that only has half of the couples identified with a specific number and the other 40 players not identified with a number. This file works , some what, but the result does not keep the unidentified couples together. The second file has all couples identified but it hangs. Keep in mind that I want to be able to do this with up to 80 couples with the result being 4somes with couples and total handicaps about the same.


It'd be helpful if you provided a XLSM with sample data and your macro

[Lowggy]

I am going to include two files, the first one called 20 couples and 40 others is a file that only has half of the couples identified with a specific number and the other 40 players not identified with a number. This file works , some what, but the result does not keep the unidentified couples together. The second file has all couples identified but it hangs. Keep in mind that I want to be able to do this with up to 80 couples with the result being 4somes with couples and total handicaps about the same.

i am not sure if I am using this forum correctly, maybe the moderator could help out. I post a problem with code and a file but I do not hear anything. I am not sure who sees this, if anyone is interested in helping or if my question will just stay here for ever. I would like to know one way or the other so I can search other help locations or bite the bullet and learn more coding.

[SamT]

It's a weekend. Many people take a break from here on weekends.

You can see all the members who see this thread by looking below the Reply Editor.

If you want fast service and want to insure someone is helping, see: http://www.vbaexpress.com/paid-help-line.html

All the rest of use are unpaid volunteers. I'm bored sitting here with an icepack on my knee, so I will look at one of your files now even though you are not online at the moment.

[SamT]

Here's my start. I'm still working on the Sort algorithm. If you find one that wolrks before me, let us know. I may be a couple of days, since I have a few things to do for myself.


Option Explicit
Option Base 1

'Note: This Code uses Sheet CodeNames, not Sheet Tab Names..
'You can change the Tab Names without changing the Code.

Sub MakeFoursomes()
Dim arSingles As Variant
Dim arCouples As Variant
Dim ar4Somes As Variant
Dim LR As Long 'LR for Last Row
Dim i As Long, j As Long


'Put Couples and Handicap totals in 2 column Array
'Start with Persons
With shCouples
LR = Cells(Rows.Count, "A").End(xlUp).Row
arSingles = Range(Cells(2, "A"), Cells(LR, "B")).Value
End With

'Test
Dim X 'Used for all tests
'X = arCouples.Address
X = UBound(arSingles, 1)
X = UBound(arSingles, 2)
'End Test

'Make Couples and sum Handicaps
ReDim arCouples(UBound(arSingles, 1) / 2, 2)
For i = 1 To UBound(arSingles, 1) Step 2
j = (i + 1) / 2
arCouples(j, 1) = arSingles(i, 1) & "; " & arSingles(i + 1, 1)
arCouples(j, 2) = arSingles(i, 2) + arSingles(i + 1, 2)
'Test
X = arCouples(j, 1) & "..." & arCouples(j, 2)
'End Test
Next

'Test
X = SortLowToHigh(arCouples)
X = IsArray(arCouples)
'End Test

arCouples = SortLowToHigh(arCouples)

'Test
X = UBound(arCouples, 1)
X = arCouples(1, 2) '& "..." & arCouples(1, 2)
'End Test


'Sort arCouples Array by Handicap Totals


'From top to middle and bottom to middle, Add couples and total handicaps to new 3 column array

'Paste New Array to Sheet Foursomes

End Sub

Private Function SortLowToHigh(arToSort As Variant) As Variant
Dim arTmp1, arTmp2
Dim i As Long, j As Long
Dim ArrayIndex As Long
Dim HC As Long 'HC for Handicap
Dim UnSorted As Boolean

arTmp1 = arToSort
ReDim arTmp2(UBound(arTmp1, 1) / 2, 2)

'Test
Dim X
X = UBound(arTmp1, 1)
X = UBound(arTmp2, 1)
'End Test
'
'
'

The shCouples sheet Object


A

B
C


Name

Handicap




Cooke, Aggie
14



Cooke, Lee
8



Dupont, Ann
12



Dupont, Gee
5



Hurley, Ann
17



Hurley, Peter
14



Larson, Pam
15



Larson, Ron
8

[Paul_Hossler]

or bite the bullet and learn more coding.

That's also a good thing, since

1. the people who help here (as in more other forums) are volunteers working for free, but also on their own schedules

2. Six months from now when you need / want to make a change or fix something, you'll be better able to do it faster yourself

[Paul_Hossler]

as close as possible the same total handicap.

How are you defining this?


For example, I took each couple (1-40), added their handicaps, and sorted in HC order

Generated foursomes by pairing from the middle up and down (#20 + #21, #19 + #22, etc.)

Give foursomes of couple numbers 6 & 15, 19 & 26, etc.

Handicap of each foursome is around 50 or 51

[Lowggy]

Here's my start. I'm still working on the Sort algorithm. If you find one that wolrks before me, let us know. I may be a couple of days, since I have a few things to do for myself.


Option Explicit
Option Base 1

'Note: This Code uses Sheet CodeNames, not Sheet Tab Names..
'You can change the Tab Names without changing the Code.

Sub MakeFoursomes()
Dim arSingles As Variant
Dim arCouples As Variant
Dim ar4Somes As Variant
Dim LR As Long 'LR for Last Row
Dim i As Long, j As Long


'Put Couples and Handicap totals in 2 column Array
'Start with Persons
With shCouples
LR = Cells(Rows.Count, "A").End(xlUp).Row
arSingles = Range(Cells(2, "A"), Cells(LR, "B")).Value
End With

'Test
Dim X 'Used for all tests
'X = arCouples.Address
X = UBound(arSingles, 1)
X = UBound(arSingles, 2)
'End Test

'Make Couples and sum Handicaps
ReDim arCouples(UBound(arSingles, 1) / 2, 2)
For i = 1 To UBound(arSingles, 1) Step 2
j = (i + 1) / 2
arCouples(j, 1) = arSingles(i, 1) & "; " & arSingles(i + 1, 1)
arCouples(j, 2) = arSingles(i, 2) + arSingles(i + 1, 2)
'Test
X = arCouples(j, 1) & "..." & arCouples(j, 2)
'End Test
Next

'Test
X = SortLowToHigh(arCouples)
X = IsArray(arCouples)
'End Test

arCouples = SortLowToHigh(arCouples)

'Test
X = UBound(arCouples, 1)
X = arCouples(1, 2) '& "..." & arCouples(1, 2)
'End Test


'Sort arCouples Array by Handicap Totals


'From top to middle and bottom to middle, Add couples and total handicaps to new 3 column array

'Paste New Array to Sheet Foursomes

End Sub

Private Function SortLowToHigh(arToSort As Variant) As Variant
Dim arTmp1, arTmp2
Dim i As Long, j As Long
Dim ArrayIndex As Long
Dim HC As Long 'HC for Handicap
Dim UnSorted As Boolean

arTmp1 = arToSort
ReDim arTmp2(UBound(arTmp1, 1) / 2, 2)

'Test
Dim X
X = UBound(arTmp1, 1)
X = UBound(arTmp2, 1)
'End Test
'
'
'

The shCouples sheet Object


A

B
C


Name

Handicap



Cooke, Aggie
14



Cooke, Lee
8



Dupont, Ann
12



Dupont, Gee
5



Hurley, Ann
17



Hurley, Peter
14



Larson, Pam
15



Larson, Ron
8














Thank you Sam, you look after your own tasks first and if you still have some free time then I really appreciate it if you continued.

[Lowggy]

How are you defining this?


For example, I took each couple (1-40), added their handicaps, and sorted in HC order

Generated foursomes by pairing from the middle up and down (#20 + #21, #19 + #22, etc.)

Give foursomes of couple numbers 6 & 15, 19 & 26, etc.

Handicap of each foursome is around 50 or 51

That looks good Paul from what I see here. I will have to download the file and try it out on my PC.

[Paul_Hossler]

The process can be automated, but the algorithm is always the hard part

[SamT]

The process can be automated, but the algorithm is always the hard part
Yeah, I thought about placing the foursomes array on a sheet for sorting. Just think it's more elegant to sort in VBA.

The algorithm I was using was to loop thru the array finding a minimum Handicap, put that record in a new array and replace that Handicap with 9999. Rinse and repeat. Sounds easy... :banghead:

[Paul_Hossler]

Yeah, I thought about placing the foursomes array on a sheet for sorting. Just think it's more elegant to sort in VBA.

The algorithm I was using was to loop thru the array finding a minimum Handicap, put that record in a new array and replace that Handicap with 9999. Rinse and repeat. Sounds easy... :banghead:

Agree, that's what I'll do, but ONLY when I have a code-able algorithm with the fuzzy areas cleared. I was only using the WS to develop a workable algorithm

For example, the simplistic assignment in my text, pairs the best couple (lowest combined HC) with the worst couple (highest HC) to have foursome average out to something close to the same

[SamT]

For example, the simplistic assignment in my text, pairs the best couple (lowest combined HC) with the worst couple (highest HC) to have foursome average out to something close to the same

THat's the closest you can get to all 4somes having the same handicap when pairing couples.

[Paul_Hossler]

The other possible approach would be to pair couples such that each half the pair has about the same total HC

e.g.

Couple A - Total HC = 20
Couple B - Total HC = 40
Couple C - Total HC = 41
Couple D - Total HC = 22

1. You could pair A and D, and pair B and C since both foursomes will have 'the same total HC' (i.e. ~20 and ~40) within the foursome and be better matched

or

2. You could pair A and C, and pair B and D since all foursomes have 'the same total HC' i.e. ~30 among all foursomes, but some foursomes will have a wide spread

Just depends on how OP wants it

[Lowggy]

The other possible approach would be to pair couples such that each half the pair has about the same total HC

e.g.

Couple A - Total HC = 20
Couple B - Total HC = 40
Couple C - Total HC = 41
Couple D - Total HC = 22

1. You could pair A and D, and pair B and C since both foursomes will have 'the same total HC' (i.e. ~20 and ~40) within the foursome and be better matched

or

2. You could pair A and C, and pair B and D since all foursomes have 'the same total HC' i.e. ~30 among all foursomes, but some foursomes will have a wide spread

Just depends on how OP wants it

Again thanks Paul, the file you provided taking 80 golfers and making 20 couples with almost equal handicaps was great. To do it for 160 golfers ie 80 couples and making 40 4somes will suffice. To have it some what automated would be great but if it will work for 160 golfers I can live with that.

[Paul_Hossler]

This could be more robust, but take a look




Option Explicit
'group name handicap
Dim aryData As Variant
'group names
Dim aryGroupNames() As Variant
'group handicap
Dim aryGroupHC() As Variant


Sub Pairs()
Dim i As Long, j As Long, MaxGroup As Long, GroupNum As Long, HoldGroup As Long, HoldHC As Long
Dim s As String
Dim rData As Range, rData1 As Range

'set data
Set rData = Worksheets("Arkusz1").Cells(1, 1).CurrentRegion
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

'sort by group num and name
With rData.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=rData1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'get max group number
With Application.WorksheetFunction
MaxGroup = .Max(rData.Columns(1))
End With

'create working arrays
ReDim aryGroupNames(1 To MaxGroup)
ReDim aryGroupHC(1 To MaxGroup, 1 To 2)
'move data into working arrays
aryData = rData.Value

For i = LBound(aryData) + 1 To UBound(aryData) Step 2
GroupNum = aryData(i, 1)
aryGroupNames(GroupNum) = aryData(i, 2) & " & " & aryData(i + 1, 2)
aryGroupHC(GroupNum, 1) = aryData(i, 1)
aryGroupHC(GroupNum, 2) = aryData(i, 3) + aryData(i + 1, 3)
Next i


'sort HC low to high simple bubble sort
For i = LBound(aryGroupHC, 1) To UBound(aryGroupHC, 1) - 1
For j = i + 1 To UBound(aryGroupHC, 1)
If aryGroupHC(i, 2) > aryGroupHC(j, 2) Then
HoldGroup = aryGroupHC(j, 1)
HoldHC = aryGroupHC(j, 2)
aryGroupHC(j, 1) = aryGroupHC(i, 1)
aryGroupHC(j, 2) = aryGroupHC(i, 2)
aryGroupHC(i, 1) = HoldGroup
aryGroupHC(i, 2) = HoldHC
End If
Next j
Next i

'outputs
With Worksheets("Arkusz2")
.UsedRange.Clear

.Cells(1, 1).Value = "Group 1"
.Cells(1, 2).Value = "Couple"
.Cells(1, 3).Value = "Handicap"

.Cells(1, 4).Value = "Group 2"
.Cells(1, 5).Value = "Couple"
.Cells(1, 6).Value = "Handicap"

.Cells(1, 7).Value = "Total Handicap"

For i = LBound(aryGroupHC, 1) To UBound(aryGroupHC, 1) \ 2
GroupNum = aryGroupHC(i, 1)
.Cells(i + 1, 1).Value = GroupNum
.Cells(i + 1, 2).Value = aryGroupNames(GroupNum)
.Cells(i + 1, 3).Value = aryGroupHC(i, 2)

GroupNum = aryGroupHC(UBound(aryGroupHC, 1) - i + 1, 1)
.Cells(i + 1, 4).Value = GroupNum
.Cells(i + 1, 5).Value = aryGroupNames(GroupNum)
.Cells(i + 1, 6).Value = aryGroupHC(UBound(aryGroupHC, 1) - i + 1, 2)

.Cells(i + 1, 7).Value = .Cells(i + 1, 3).Value + .Cells(i + 1, 6).Value
Next i
.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
End With
End Sub

[SamT]

Paul, it looks like you've got it taken care of.

I'm moving on, unless something comes up.

[Paul_Hossler]

Paul, it looks like you've got it taken care of.

I'm moving on, unless something comes up.


You've been around long enough to know that something ALWAYS comes up :rotflmao:

[Lowggy]

This could be more robust, but take a look




Option Explicit
'group name handicap
Dim aryData As Variant
'group names
Dim aryGroupNames() As Variant
'group handicap
Dim aryGroupHC() As Variant


Sub Pairs()
Dim i As Long, j As Long, MaxGroup As Long, GroupNum As Long, HoldGroup As Long, HoldHC As Long
Dim s As String
Dim rData As Range, rData1 As Range

'set data
Set rData = Worksheets("Arkusz1").Cells(1, 1).CurrentRegion
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

'sort by group num and name
With rData.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=rData1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rData1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'get max group number
With Application.WorksheetFunction
MaxGroup = .Max(rData.Columns(1))
End With

'create working arrays
ReDim aryGroupNames(1 To MaxGroup)
ReDim aryGroupHC(1 To MaxGroup, 1 To 2)
'move data into working arrays
aryData = rData.Value

For i = LBound(aryData) + 1 To UBound(aryData) Step 2
GroupNum = aryData(i, 1)
aryGroupNames(GroupNum) = aryData(i, 2) & " & " & aryData(i + 1, 2)
aryGroupHC(GroupNum, 1) = aryData(i, 1)
aryGroupHC(GroupNum, 2) = aryData(i, 3) + aryData(i + 1, 3)
Next i


'sort HC low to high simple bubble sort
For i = LBound(aryGroupHC, 1) To UBound(aryGroupHC, 1) - 1
For j = i + 1 To UBound(aryGroupHC, 1)
If aryGroupHC(i, 2) > aryGroupHC(j, 2) Then
HoldGroup = aryGroupHC(j, 1)
HoldHC = aryGroupHC(j, 2)
aryGroupHC(j, 1) = aryGroupHC(i, 1)
aryGroupHC(j, 2) = aryGroupHC(i, 2)
aryGroupHC(i, 1) = HoldGroup
aryGroupHC(i, 2) = HoldHC
End If
Next j
Next i

'outputs
With Worksheets("Arkusz2")
.UsedRange.Clear

.Cells(1, 1).Value = "Group 1"
.Cells(1, 2).Value = "Couple"
.Cells(1, 3).Value = "Handicap"

.Cells(1, 4).Value = "Group 2"
.Cells(1, 5).Value = "Couple"
.Cells(1, 6).Value = "Handicap"

.Cells(1, 7).Value = "Total Handicap"

For i = LBound(aryGroupHC, 1) To UBound(aryGroupHC, 1) \ 2
GroupNum = aryGroupHC(i, 1)
.Cells(i + 1, 1).Value = GroupNum
.Cells(i + 1, 2).Value = aryGroupNames(GroupNum)
.Cells(i + 1, 3).Value = aryGroupHC(i, 2)

GroupNum = aryGroupHC(UBound(aryGroupHC, 1) - i + 1, 1)
.Cells(i + 1, 4).Value = GroupNum
.Cells(i + 1, 5).Value = aryGroupNames(GroupNum)
.Cells(i + 1, 6).Value = aryGroupHC(UBound(aryGroupHC, 1) - i + 1, 2)

.Cells(i + 1, 7).Value = .Cells(i + 1, 3).Value + .Cells(i + 1, 6).Value
Next i
.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
End With
End Sub


Paul, I have suddenly turned very ill and was at a Dr. This morning. Your work looks great. I can not thank you enough for doing this. Hopefully I can lear to code like you some day.

[Paul_Hossler]

Paul, I have suddenly turned very ill and was at a Dr. This morning. Your work looks great. I can not thank you enough for doing this. Hopefully I can lear to code like you some day.

I've written some terrible code in my (many) days, but I never had it make anyone ill before:rofl: