create fixtures but 2 vs 2

K

kerm007

Active Member
Joined
Mar 16, 2019
Messages
266
Office Version
  1. 365
Platform
  1. Windows
Hello
i have a macro vb that create fixtures 1 number vs 1 number but how can i do the same but took 2 numbers instead of 1 to create 2 vs 2 fixtures ?

VBA Code: 
Sub Main(ByVal Control As IRibbonControl)
Dim teamArray As Variant
Dim i As Long, n As Long, x As Long, p As Long, j As Integer
Dim nrow As Integer, nTeam As Integer, ncopyrow As Integer, iRow As Integer
Dim Ngame As String

imsg = MsgBox("Would you like to create a new fixture list?" & Chr(10) & "By click 'Yes' all existing fixtures and results will be erased", vbYesNo)

Application.ScreenUpdating = False

If imsg = vbNo Then
Exit Sub
End If

If Sheet1.Range("C5").Value = "" Then
MsgBox ("No teams have been entered on the Teams tab.")
Exit Sub
End If


Call Env_Var

Sheet2.Cells.ClearContents
Sheet3.Cells.Delete


If Range("Teams").Count Mod 2 <> 0 Then

Range("Col_Team").Offset(Range("Teams").Count + 1, 0).Value = v_Team
Range("Col_Team").Offset(Range("Teams").Count, -1).Value = Range("Col_Team").Offset(Range("Teams").Count - 1, -1).Value + 1
Range("Col_Team").Offset(Range("Teams").Count, 1).Value = v_Venue

End If


teamArray = Range("Teams")
teamArray = ShuffleArrayInPlace(teamArray)


nrow = UBound(teamArray) / 2
nTeam = UBound(teamArray)

ncopyrow = nrow

   For i = LBound(teamArray) To UBound(teamArray) / 2
    Sheet2.Cells(i, "A") = teamArray(i, 1)
   Next i

   For n = (UBound(teamArray) / 2) + 1 To UBound(teamArray)
    Sheet2.Cells((n - (UBound(teamArray) / 2)), "B") = teamArray(n, 1)
   Next n
    
Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A1")

ncopyrow = nrow + 2

For x = 1 To nTeam - 2
If x Mod 2 = 0 Then

Call Even
Else
Call Odd

End If

Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A" & ncopyrow)

ncopyrow = ncopyrow + nrow + 1

Next x



If v_Play > 1 Then
'CODE HERE

For p = 2 To v_Play

iRow = iRow + ncopyrow

If p Mod 2 = 0 Then
'Even
Sheet3.Range("B1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow)
Sheet3.Range("A1:A" & ncopyrow - 2).Copy Sheet3.Range("B" & iRow)
Else
Sheet3.Range("A1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow - 1)

iRow = iRow - 2

End If
'Odd
Next p

End If


Sheet2.Cells.ClearContents


Format_Fixtures ((Sheet3.Range("A1048576").End(xlUp).Row))

Sheet3.Select

Application.ScreenUpdating = True

End Sub


Sub League_Table(ByVal Control As IRibbonControl)
Dim iRow As Integer, Rslt As Integer, aRow As Integer
Dim c As Range, xTable As Range
Dim z As Range, IRange As Range
Dim H As Integer, A As Integer
Dim p As Range
Dim hTeam As String, aTeam As String
Dim hScore As Integer, aScore As Integer, aBouns As Integer, hBonus As Integer
Dim nOrd As Integer, nVal As Integer, i As Integer

Application.ScreenUpdating = False

iRow = Sheet3.Range("B1048576").End(xlUp).Row
Call Env_Var
Call Format_League


For Each c In Sheet3.Range("B5:B" & iRow)

hTeam = c.Text
aTeam = c.Offset(0, 4).Text
hScore = c.Offset(0, 1).Value
aScore = c.Offset(0, 3).Value
aBonus = 0
hBonus = 0

If InStr(1, hTeam, "Fixture") = 0 Then

H = Sheet6.Range("C:C").Find(hTeam).Row
A = Sheet6.Range("C:C").Find(aTeam).Row

If c.Offset(0, 1).Value = "" And c.Offset(0, 3).Value = "" Then

If Sheet6.Cells(H, NX).Value = "" And Sheet6.Cells(A, NX).Value = "" Then
Sheet6.Cells(H, NX).Value = "(H) v " & aTeam
Sheet6.Cells(A, NX).Value = "(A) v " & hTeam
End If

Else

With Sheet6
'Pl Home
.Cells(H, Pl).Value = .Cells(H, Pl).Value + 1
'Pl Away
.Cells(A, Pl).Value = .Cells(A, Pl).Value + 1

'Bonus Point for Score
If Range("at_BP_Score_Op").Value = "" Or Range("at_BP_Score_Score").Value = "" Or Range("at_BP_Score_Points").Value = "" Then
    Else
        If Range("at_BP_Score_Op").Value = "Greater than" Then
            If hScore > Range("at_BP_Score_Score").Value Then hBonus = hBonus + Range("at_BP_Score_Points").Value
            If aScore > Range("at_BP_Score_Score").Value Then aBonus = aBonus + Range("at_BP_Score_Points").Value
        Else
            If hScore >= Range("at_BP_Score_Score").Value Then hBonus = hBonus + Range("at_BP_Score_Points").Value
            If aScore >= Range("at_BP_Score_Score").Value Then aBonus = aBonus + Range("at_BP_Score_Points").Value
        End If
    End If


If hScore > aScore Then
'Wins Home
.Cells(H, W).Value = .Cells(H, W).Value + 1
.Cells(H, FM).Value = Left(.Cells(H, FM).Value, v_From) & "W"
    If Range("at_BP_Win_Op").Value = "" Or Range("at_BP_Win_Score").Value = "" Or Range("at_BP_Margin").Value = "" Then
    Else
        If Range("at_BP_Win_Op").Value = "Greater than" Then
            If (hScore - aScore) > Range("at_BP_Win_Score").Value Then hBonus = hBonus + Range("at_BP_Margin").Value
        Else
            If (hScore - aScore) >= Range("at_BP_Win_Score").Value Then hBonus = hBonus + Range("at_BP_Margin").Value
        End If
    End If
End If

If aScore > hScore Then
'Wins Away
.Cells(A, W).Value = .Cells(A, W).Value + 1
.Cells(A, FM).Value = Left(.Cells(A, FM).Value, v_From) & "W"
    If Range("at_BP_Win_Op").Value = "" Or Range("at_BP_Win_Score").Value = "" Or Range("at_BP_Margin").Value = "" Then
    Else
        If Range("at_BP_Win_Op").Value = "Greater than" Then
            If (aScore - hScore) > Range("at_BP_Win_Score").Value Then aBonus = aBonus + Range("at_BP_Margin").Value
        Else
            If (aScore - hScore) >= Range("at_BP_Win_Score").Value Then aBonus = aBonus + Range("at_BP_Margin").Value
        End If
    End If
End If

If hScore = aScore Then
'Draws Home
.Cells(H, D).Value = .Cells(H, D).Value + 1
.Cells(H, FM).Value = Left(.Cells(H, FM).Value, v_From) & "D"
End If

If aScore = hScore Then
'Draws Away
.Cells(A, D).Value = .Cells(A, D).Value + 1
.Cells(A, FM).Value = Left(.Cells(A, FM).Value, v_From) & "D"
End If

If hScore < aScore Then
'Losses Home
.Cells(H, L).Value = .Cells(H, L).Value + 1
.Cells(H, FM).Value = Left(.Cells(H, FM).Value, v_From) & "L"
End If

If aScore < hScore Then
'Losses Away
.Cells(A, L).Value = .Cells(A, L).Value + 1
.Cells(A, FM).Value = Left(.Cells(A, FM).Value, v_From) & "L"
End If

'Goals For Home
.Cells(H, GF).Value = .Cells(H, GF).Value + hScore
'Goals Against Home
.Cells(H, GA).Value = .Cells(H, GA).Value + aScore

'Goals For Away
.Cells(A, GF).Value = .Cells(A, GF).Value + aScore
'Goals Against Away
.Cells(A, GA).Value = .Cells(A, GA).Value + hScore

'Goal Difference Home
.Cells(H, GD).Value = .Cells(H, GF).Value - .Cells(H, GA).Value
'Goal Difference Away
.Cells(A, GD).Value = .Cells(A, GF).Value - .Cells(A, GA).Value

'Points Home
.Cells(H, Pts).Value = (.Cells(H, W).Value * v_Win) + (.Cells(H, D).Value * v_Draw) + (.Cells(H, L).Value * v_Loss) + hBonus
'Points Away
.Cells(A, Pts).Value = (.Cells(A, W).Value * v_Win) + (.Cells(A, D).Value * v_Draw) + (.Cells(A, L).Value * v_Loss) + aBonus



End With
End If
End If
Next c

'Sort the Table
Set xTable = Sheet6.Range(Sheet6.Cells(4, 2), Sheet6.Cells(ntbl, 13))

If Range("P_Order_Value").Value = "" Or Range("P_Order_Value").Offset(0, 1).Value = "" Then
Set IRange = Range("P_Order_Df")
Else
Set IRange = Range("P_Order")
End If

Sheet6.Sort.SortFields.Clear

For Each z In IRange

If z.Value = "" Or z.Offset(0, 1).Value = "" Then

Else

nVal = Application.WorksheetFunction.VLookup(z.Value, Range("LIST"), 2, 0)
nOrd = Application.WorksheetFunction.VLookup(z.Offset(0, 1).Value, Range("Order"), 2, 0)

    Sheet6.Sort.SortFields.Add Key:=Sheet6.Range( _
        Sheet6.Cells(5, nVal), Sheet6.Cells(ntbl, nVal)), SortOn:=xlSortOnValues, Order:=nOrd, DataOption:= _
        xlSortNormal
 
End If

Next z

    With Sheet6.Sort
        .SetRange xTable
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

aRow = Sheet6.Range("C1048576").End(xlUp).Row

For Each p In Sheet6.Range("C5:C" & aRow)
i = i + 1
p.Offset(0, -1).Value = i

For j = 1 To 8
If p.Offset(0, j).Value = "" Then p.Offset(0, j).Value = 0
Next j

Next p

Application.ScreenUpdating = True

End Sub


Thanks
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
instead of a 200+ lines of code that does not do what you want it to, maybe you should take the time and explain what you do want to achieve.
 
Upvote 0
i want to be able to create fixtures but 2 players against 2 players
it took numbers from a sheets called TEAMS and create a fixtures 1 vs 1
for now it work on what i was doing


i think only that part is needed :

VBA Code: 
Sub Main(ByVal Control As IRibbonControl)
Dim teamArray As Variant
Dim i As Long, n As Long, x As Long, p As Long, j As Integer
Dim nrow As Integer, nTeam As Integer, ncopyrow As Integer, iRow As Integer
Dim Ngame As String

imsg = MsgBox("Would you like to create a new fixture list?" & Chr(10) & "By click 'Yes' all existing fixtures and results will be erased", vbYesNo)

Application.ScreenUpdating = False

If imsg = vbNo Then
Exit Sub
End If

If Sheet1.Range("C5").Value = "" Then
MsgBox ("No teams have been entered on the Teams tab.")
Exit Sub
End If


Call Env_Var

Sheet2.Cells.ClearContents
Sheet3.Cells.Delete


If Range("Teams").Count Mod 2 <> 0 Then

Range("Col_Team").Offset(Range("Teams").Count + 1, 0).Value = v_Team
Range("Col_Team").Offset(Range("Teams").Count, -1).Value = Range("Col_Team").Offset(Range("Teams").Count - 1, -1).Value + 1
Range("Col_Team").Offset(Range("Teams").Count, 1).Value = v_Venue

End If


teamArray = Range("Teams")
teamArray = ShuffleArrayInPlace(teamArray)


nrow = UBound(teamArray) / 2
nTeam = UBound(teamArray)

ncopyrow = nrow

   For i = LBound(teamArray) To UBound(teamArray) / 2
    Sheet2.Cells(i, "A") = teamArray(i, 1)
   Next i

   For n = (UBound(teamArray) / 2) + 1 To UBound(teamArray)
    Sheet2.Cells((n - (UBound(teamArray) / 2)), "B") = teamArray(n, 1)
   Next n
    
Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A1")

ncopyrow = nrow + 2

For x = 1 To nTeam - 2
If x Mod 2 = 0 Then

Call Even
Else
Call Odd

End If

Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A" & ncopyrow)

ncopyrow = ncopyrow + nrow + 1

Next x



If v_Play > 1 Then
'CODE HERE

For p = 2 To v_Play

iRow = iRow + ncopyrow

If p Mod 2 = 0 Then
'Even
Sheet3.Range("B1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow)
Sheet3.Range("A1:A" & ncopyrow - 2).Copy Sheet3.Range("B" & iRow)
Else
Sheet3.Range("A1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow - 1)

iRow = iRow - 2

End If
'Odd
Next p

End If


Sheet2.Cells.ClearContents


Format_Fixtures ((Sheet3.Range("A1048576").End(xlUp).Row))

Sheet3.Select

Application.ScreenUpdating = True

End Sub
Thanks
 
Upvote 0
I am sorry. I don't have a clue what fixtures are.
 
Upvote 0
Can you try the updated version and share the result?


VBA Code: 
Sub Main(ByVal Control As IRibbonControl)
    Dim teamArray As Variant
    Dim i As Long, n As Long, x As Long, p As Long
    Dim nrow As Integer, nTeam As Integer, ncopyrow As Integer, iRow As Integer
    Dim numTeams As Integer, numPairs As Integer
    Dim pairArray() As Variant
    Dim imsg As Variant
    
    imsg = MsgBox("Would you like to create a new fixture list?" & Chr(10) & "By clicking 'Yes' all existing fixtures and results will be erased", vbYesNo)
    
    Application.ScreenUpdating = False
    
    If imsg = vbNo Then
        Exit Sub
    End If
    
    If Sheet1.Range("C5").Value = "" Then
        MsgBox ("No teams have been entered on the Teams tab.")
        Exit Sub
    End If
    
    Call Env_Var
    
    Sheet2.Cells.ClearContents
    Sheet3.Cells.Delete
    
    teamArray = Sheet1.Range("Teams").Value
    teamArray = ShuffleArrayInPlace(teamArray)
    numTeams = UBound(teamArray)
    
    If numTeams Mod 4 <> 0 Then
        Dim numToAdd As Integer
        numToAdd = 4 - (numTeams Mod 4)
        ReDim Preserve teamArray(1 To numTeams + numToAdd, 1 To 1)
        For i = numTeams + 1 To numTeams + numToAdd
            teamArray(i, 1) = "BYE"
        Next i
        numTeams = numTeams + numToAdd
    End If
    
    numPairs = numTeams / 2
    ReDim pairArray(1 To numPairs, 1 To 1)
    Dim pairIndex As Integer
    pairIndex = 1
    For i = 1 To numTeams Step 2
        pairArray(pairIndex, 1) = teamArray(i, 1) & " & " & teamArray(i + 1, 1)
        pairIndex = pairIndex + 1
    Next i
    
    nrow = numPairs / 2
    ncopyrow = nrow
    
    For i = 1 To nrow
        Sheet2.Cells(i, "A") = pairArray(i, 1)
    Next i
    
    For n = nrow + 1 To numPairs
        Sheet2.Cells(n - nrow, "B") = pairArray(n, 1)
    Next n
    
    Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A1")
    
    ncopyrow = nrow + 2
    
    For x = 1 To numPairs - 2
        If x Mod 2 = 0 Then
            Call Even_Pairs(pairArray)
        Else
            Call Odd_Pairs(pairArray)
        End If
        
        For i = 1 To nrow
            Sheet2.Cells(i, "A") = pairArray(i, 1)
            Sheet2.Cells(i, "B") = pairArray(i + nrow, 1)
        Next i
        
        Sheet2.Range("A1:B" & nrow).Copy Sheet3.Range("A" & ncopyrow)
        ncopyrow = ncopyrow + nrow + 1
    Next x
    
    If v_Play > 1 Then
        For p = 2 To v_Play
            iRow = iRow + ncopyrow
            If p Mod 2 = 0 Then
                Sheet3.Range("B1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow)
                Sheet3.Range("A1:A" & ncopyrow - 2).Copy Sheet3.Range("B" & iRow)
            Else
                Sheet3.Range("A1:B" & ncopyrow - 2).Copy Sheet3.Range("A" & iRow - 1)
                iRow = iRow - 2
            End If
        Next p
    End If
    
    Sheet2.Cells.ClearContents
    
    Format_Fixtures (Sheet3.Range("A1048576").End(xlUp).Row)
    
    Sheet3.Select
    
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hello
Thanks for this
i get this :

1728831625781.png


Regards
 
Upvote 0
You must log in or register to reply here.

Similar threads

Gideon du Toit
  • Locked
  • Question Question
Sub not firing after Call
Replies
1
Views
419
Fluff
Fluff
Gideon du Toit
  • Solved
Simple Sub Procedure Call not running
2 3 4
Replies
33
Views
4K
RoryA
RoryA
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
813
Agnarr
Agnarr
S
  • Question Question
Accumulate Data from 10k+ Files. Very Slow. Issue with ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
2
Replies
10
Views
987
NdNoviceHlp
NdNoviceHlp
S
  • Question Question
Creating a dynamic Subject line from information in a particular Excel column
Replies
0
Views
662
StevieMP
S

Forum statistics

Threads
1,223,880
Messages
6,175,153
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top