Sorteio de Jogos Futebol

Ola amigos,

Estou com um bd que faz sorteio de jogos de futebol.. o codigo atual faz esse sorteio mas gostaria de fazer uma modificação pois hj ele faz o sorteio de todos os jogos da equipe x na tela na sequencia ex: se tiver 4 times

PALMEIRAS
SANTOS
VASCO
CRUZEIRO

Fica assim na tabela:

1 PALMEIRAS X SANTOS
2 PALMEIRAS X VASCO
3 PALMEIRAS X CRUZEIRO
4 SANTOS X PALMEIRAS
5 SANTOS X VASCO
6 SANTOS X CRUZEIRO
7 VASCO X PALMEIRAS
8 VASCO X SANTOS
9VASCO CRUZEIRO

E assim por diante mas preciso que ele ficasse na ordem ex:

1 PALMEIRAS X SANTOS
2 VASCO X CRUZEIRO
3 SANTOS X VASCO
4 CRUZEIRO X PALMEIRAS

E assim por diante.. meu código é o segunte:

Código:

Private Sub Sorteio_Click()

If MsgBox("Confirmar Sorteio ? ", vbYesNo + vbQuestion, "Gestão de Futebol") = vbYes Then

Dim Rst1 As DAO.Recordset, Rst2 As DAO.Recordset

CurrentDb.Execute "DELETE * FROM Partidas;"
Set Rst1 = CurrentDb.OpenRecordset("SELECT Equipe FROM Equipes;")
Set Rst2 = CurrentDb.OpenRecordset("SELECT Equipe FROM Equipes;")
Do While Not Rst1.EOF
Rst2.MoveFirst
Do While Not Rst2.EOF
If Rst1(0) <> Rst2(0) Then CurrentDb.Execute "INSERT INTO Partidas(Visitado,Visitante) VALUES ('" & Rst1(0) & "','" & Rst2(0) & "');"
Rst2.MoveNext
Loop
Rst1.MoveNext
Loop
Set Rst1 = Nothing: Set Rst2 = Nothing
MsgBox "Sorteio Terminado.", vbQuestion, "Gestão de Futebol"
Call Comando33_Click
End If
End Sub

Bom dia,

Faça o sorteio através de rodadas. Na tabela onde grava o jogos, adicione um campo "rodada" e la voce preencha com cada rodada. E no loop, faça com que o código verifique se o time1 ou o time2 já está presente na tabela para a rodada em questão. Caso sim, faça-o pular o loop e verifique até que caia um jogo que não esteja cadastrado para a rodada.

-------------------------------
EDIT

fiz um pequeno modelo aqui só com 4 times e apenas turno, sem returno. Só pra exemplificar o que quis dizer. Abra o formSorteio e veja os jogos já cadastrados. Depois clique em limpar e faça um novo sorteio. Os jogos são sorteados de forma aleatória. Um time não jogará nunca na mesma rodada e dois jogos nao aconterão em rodadas distintas. Caso queira fazer mais jogos, basta acrescentar times na tblTimes e o código já fará tudo automaticamente, porém só funciona para número par de times.

Código:

    If MsgBox("Confirma o sorteio?", vbQuestion + vbYesNo, "Sorteio") = vbNo Then Exit Sub
   
    Dim qntRodadas As Integer
    Dim time1, time2 As Integer
    Dim nomeTime1, nomeTime2 As String
    Dim booRepeat As Boolean
    Dim j As Integer
   
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT COUNT(codigo) as c FROM tblTimes")
    Set rs1 = db.OpenRecordset("tblJogos")
   
    qntRodadas = rs!c - 1 'estou fazendo aqui apenas turno, sem returno
    j = 1

    For i = 1 To qntRodadas
        For j = 1 To (rs!c / 2) Step 0
            booRepeat = True
       
            Do While booRepeat = True
                Randomize
                time1 = Int(Rnd() * 4) + 1
               
                Randomize
                time2 = Int(Rnd() * 4) + 1
               
                If time1 <> time2 Then
                    Dim str, st As String
                   
                    str = "SELECT COUNT(codigo) as c FROM tblJogos WHERE (codigotime1 = " & time1 & " or codigotime1 = " & time2 & " "
                    str = str & "Or codigotime2 = " & time1 & " Or codigotime2 = " & time2 & ") And rodada = " & i & ""
                   
                    st = "SELECT COUNT(codigo) as c FROM tblJogos WHERE (codigotime1 = " & time1 & " and codigotime2 = " & time2 & ") or "
                    st = st & "(codigotime1 = " & time2 & " and codigotime2 = " & time1 & ")"
                   
                    Dim r, s As Recordset
                   
                    Set r = db.OpenRecordset(str)
                    Set s = db.OpenRecordset(st)
                   
                    If r!c = 0 And s!c = 0 Then
                        booRepeat = False
                    End If
                   
                    r.Close
                End If
            Loop
           
            Dim rsTimes As Recordset
            Set rsTimes = db.OpenRecordset("SELECT * FROM tblTimes WHERE codigo = " & time1 & "")
           
            nomeTime1 = rsTimes!nometime
           
            rsTimes.Close
           
            Set rsTimes = db.OpenRecordset("SELECT * FROM tblTimes WHERE codigo = " & time2 & "")
            nomeTime2 = rsTimes!nometime
           
            rsTimes.Close
           
            rs1.AddNew
                rs1("rodada") = i
                rs1("codigotime1") = time1
                rs1("time1") = nomeTime1
                rs1("codigotime2") = time2
                rs1("time2") = nomeTime2
            rs1.Update
           
            j = j + 1
        Next
   
        j = 1
    Next i
   
    MsgBox "Sorteio realizado com sucesso!", vbInformation, "Sorteio"
    cbxJogos.Requery


Abraço.

Boa tarde CassioFabre!

Muito bacana este seu modelo, ha algum tempo estava querendo desenvolver um sistema para geração de campeonatos de vídeo games (FIFA e/ou PES), mais devido ao tempo não levei a frente.
Mais este seu modelo me depertou o desejo de terminar este meu projeto, porem ao efetuar um teste de sorteio contendo os 20 times do brasileirão 2017, o access demorou 4 minutos para montar os 2 primeiro jogo.  

Ao efetuar um teste contendo uma quantidade de times maior travou ai também ?

desde de já agradeço.

Boa tarde,

Como eu fiz de uma meneira que o access sorteie aleatoriamente os times, quanto maior a quantidade de times mais tempo vai demorar. O mais correto seria criar algum tipo de criterio pra ele resetar. Por exemplo, voce pode criar uma variável que armazerá o código dos times já cadastrados naquela rodada, caso a função rnd() retorne um valor já cadastrado, voce faz com que ela nao aceite esse valor e faça um novo sorteio. Então, quando achar dois times que ainda nao foram cadastrados naquela, faça o código verificar se aquele jogo em questão já não foi cadastrado numa rodada anterior (isso este modelinho que passei já faz) e caso verdadeiro, grave o jogo na tabela, caso falso, faça com que sorteie novamente.

É facil ver que esse processo vai ser cada vez mais demorado se voce inserir cada vez mais times no sorteio. Isso porque, da forma que fiz, o access nao consegue excluir "do saco" os times já cadastrados. Porque a função rnd() sorteia sempre os mesmo valores. Então a probabilidade de um time ja sorteado cair é basicamente a mesma em todas as rotações.

Pesando aqui agora, talvez uma alternativa seria criar um campo booleano na tabela e ir marcando cada vez que o time seja incluído na rodada, gravar os códigos dos times restantes num vetor e fazer o access sortear os times dentro desse vetor. E o restante das verificações fique normal (com o adendo de caso o jogo "passar" na verificação, não esquecer de marcar o campo booleano para os dois times restantes). Acredito que diminuiria consideravelmente o tempo de sorteio e também não cairia no problema do loop infinito.

Tenta aí e retorne.

Abraço.

Eae

Fiz um pequeno sisteminha para organizar sem repetir, não sei se é o jeito correto, mas acho que serve, bom, ele está bem por cima, não ta salvando no banco nem nada... Segue anexo e o código

Código:


    Dim rs As DAO.Recordset
    Dim times As Variant
    Dim sorteio As String, sequencia As String
    Dim numTimes As Integer
    Set rs = CurrentDb.OpenRecordset("Times")
    numTimes = rs.RecordCount
    Me.result.Caption = ""
    If numTimes > 0 Then
        For i = 1 To numTimes
            For x = 1 To numTimes - (i - 1)
                sequencia = sequencia & rs("Time") & IIf(x = (numTimes - (i - 1)), "", ", ")
            Next
            sequencia = sequencia & vbCrLf
            rs.MoveNext
        Next
        times = Split(sequencia, vbCrLf)
        For i = 0 To UBound(times) - 1
            For x = (i + 1) To UBound(Split(times(i), ", ")) + i
                 Me.result.Caption = Me.result.Caption & Split(times(i), ", ")(0) & " - " & Split(times(x), ", ")(0) & vbCrLf
            Next
        Next
    End If


Aqui tem uma tabela com o nome "Times", la tem o campo "Time" <--- É onde estão os times

---------------------------------------------------
EDIT

Se você quiser colocar mais times, mude o local onde vai sair os resultados (de rótulo para caixa de texto), pois vai dar um erro falando que "A configuração desta propriedade está muito longa"

Boa tarde,

Show, roberval! Mas a minha ideia é um pouco mais elaborada, pois no seu caso nao separa os jogos por rodada, faz o mesmo do amigo que abriu o tópico. O mais complicado é fazer os jogos nao repetirem à medida que as rodadas vão passando. Mas se fizer algo como falei acima, acredito que de certo.

Abraço.

Olá Cassio

Ficou show de bola só a questão de ter mais de 4 equipes para ele gerar o sorteio e ficar completo..

Obrigado.

Alguém tem alguma idéia de como conseguir incluir mais Times sem travar ?

Obrigado

Bom dia,

De uma olhada no exemplo da mensagem nº 9 do tópico https://www.maximoaccess.com/t32731-trava-em-sorteio-aleatorio veja o código que montei com o botão. Talvez a lógica resolva o problema da inclusão de muitos itens.

Abraço.

Algum avanço aqui? A dica do Cassio resolveu?

Não esqueça de sempre fechar seus tópicos solucionados. Isso permite a organização da casa e faz membros com dúvidas semelhantes saberem que tópicos nesse status possuem um possível solução.

Veja como fazer
https://www.maximoaccess.com/t860-resolucao-de-topicos#5263

Também conheça as regas do fórum
https://www.maximoaccess.com/t48-regras-do-forum

Infelizmente estou no mesmo lugar sem avanço algum

Obrigado

Alguém pode me ajudar nesse projeto pois nao consegui ainda avancar.

Obrigdo

Alguem pode me ajudar a incluir quantidade que desejar e não somente 4 times, abaixo o codigo:

Código:

  If MsgBox("Confirma o sorteio?", vbQuestion + vbYesNo, "Sorteio") = vbNo Then Exit Sub
   
    Dim qntRodadas As Integer
    Dim time1, time2 As Integer
    Dim nomeTime1, nomeTime2 As String
    Dim booRepeat As Boolean
    Dim j As Integer
   
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT COUNT(codigo) as c FROM tblTimes")
    Set rs1 = db.OpenRecordset("tblJogos")
   
    qntRodadas = rs!c - 1 'estou fazendo aqui apenas turno, sem returno
    j = 1

    For i = 1 To qntRodadas
        For j = 1 To (rs!c / 2) Step 0
            booRepeat = True
       
            Do While booRepeat = True
                Randomize
                time1 = Int(Rnd() * 4) + 1
               
                Randomize
                time2 = Int(Rnd() * 4) + 1
               
                If time1 <> time2 Then
                    Dim str, st As String
                   
                    str = "SELECT COUNT(codigo) as c FROM tblJogos WHERE (codigotime1 = " & time1 & " or codigotime1 = " & time2 & " "
                    str = str & "Or codigotime2 = " & time1 & " Or codigotime2 = " & time2 & ") And rodada = " & i & ""
                   
                    st = "SELECT COUNT(codigo) as c FROM tblJogos WHERE (codigotime1 = " & time1 & " and codigotime2 = " & time2 & ") or "
                    st = st & "(codigotime1 = " & time2 & " and codigotime2 = " & time1 & ")"
                   
                    Dim r, s As Recordset
                   
                    Set r = db.OpenRecordset(str)
                    Set s = db.OpenRecordset(st)
                   
                    If r!c = 0 And s!c = 0 Then
                        booRepeat = False
                    End If
                   
                    r.Close
                End If
            Loop
           
            Dim rsTimes As Recordset
            Set rsTimes = db.OpenRecordset("SELECT * FROM tblTimes WHERE codigo = " & time1 & "")
           
            nomeTime1 = rsTimes!nometime
           
            rsTimes.Close
           
            Set rsTimes = db.OpenRecordset("SELECT * FROM tblTimes WHERE codigo = " & time2 & "")
            nomeTime2 = rsTimes!nometime
           
            rsTimes.Close
           
            rs1.AddNew
                rs1("rodada") = i
                rs1("codigotime1") = time1
                rs1("time1") = nomeTime1
                rs1("codigotime2") = time2
                rs1("time2") = nomeTime2
            rs1.Update
           
            j = j + 1
        Next
   
        j = 1
    Next i
   
    MsgBox "Sorteio realizado com sucesso!", vbInformation, "Sorteio"
    cbxJogos.Requery
End Sub