locked
Como faco um código vba excel para filtrar as combinaçôes geradas afim de reduzir o numero de jogos RRS feed

  • Pergunta

  • Boa tarde

    Estou tentanto ajustar o código postado pelo Natan Silva em 10/03/15 (parabéns por publica-lo), mais não sei fazer o filtro para :

    1 - gostaria de escolher certo numero de dezenas ( e criar jogos com elas) gerando todas os jogos possíveis

    2- Como é um filtro para lotomania, gostaria que completasse as 50 dezenas para cada jogo

    3- permitisse apenas 5 numeros por linha e 5 cinco por coluna

    por exemplo:

    de 1 a 10 somente 5 dezenas, de 20 a 30 somente 5 dezenas.

    e 5, 15, 25, 35, 45, 55, 65, 75, 85, 95 = permitisse também somente 5, ou seja com o mesmo final só 5 jogo

    Por favor preciso de ajuda:

    Segue código publicado por Natan Silva, 10/03/15

    Option Explicit

    'C(n, p) = n! / ((n-p)! * p!)
    'lPermutações a ser definido, seria o 'p' da fórmula acima
    Const lPermutações As Long = 6
    Dim r As Long
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim intGrupo As Integer
    Dim x As Byte 'apenas um contador para o laço
    Dim v(1 To 60)

    Sub Teste()

       
    Dim lElementos As Long
       
       
    'Popula vetor de elementos
       
    For x = 1 To 60    'coloquei em um laço pro código ficar mais limpo
            v
    (x) = CStr(x)
       
    Next x
      
        intGrupo
    = 0  'inicia o numero do grupo

       
    'C(n, p) = n! / ((n-p)! * p!)
       
    'lElementos seria o 'n' da fórmula acima
        lElementos
    = UBound(v) - LBound(v) + 1
       
       
    'Contador de linhas para uso no Excel:
        r
    = 0
       
       
    'Limpa Planilha ativa
        Cells
    .Delete
       
       
    'Inicia recursão:
        Combina
    ção lElementos, lPermutações, 1
       
    'aqui salva o último wbk aberto após fazer todas as permutações
        wkb
    .SaveAs ThisWorkbook.Path & "\perm" & intGrupo & ".xlsx"
        wkb
    .Close

       
    End Sub

    Sub Combinação(n As Long, p As Long, k As Long, Optional s As String)
       
       
       
    If p > n - k + 1 Then Exit Sub
       
       
    If p = 0 Then
           
    'Para visualizar o resultado de uma combinação no Excel:
           
           
    If r = 0 And wkb Is Nothing Then    'aqui se a linha for zero,
               
               
    Set wkb = Workbooks.Add
               
    Set wks = wkb.Sheets.Add 'adicionar uma nova guia
                intGrupo
    = intGrupo + 1  'incrementar o numero do grupo
                wks
    .Name = "grupo " & intGrupo  'renomear a guia pelo nome do grupo
               
           
    End If
           
           
           
    If funVerificaPermitacao(s) Then
             
              r
    = r + 1
              wks
    .Cells(r, "A").Resize(1, lPermutações) = Split(s, "|")
             
           
    Else
             
    'Debug.Print s 'Apenas para verificar as condicoes que não entravam
           
    End If
           
           
    'Se quiser visualizar o resultado na Janela de Verificação imediata, use:
           
    'Debug.Print s
           
    If r = 1000000 Then 'se a linha for igual a cem mil, salvar o wbk
               
                wkb
    .SaveAs ThisWorkbook.Path & "\perm" & intGrupo & ".xlsx"
                wkb
    .Close
               
    Set wkb = Nothing
                r
    = 0  'resetar o numero da linha
               
           
    End If
           
           
    Exit Sub
           
       
    End If
       
       
    'Recorre novamente:
        Combina
    ção n, p - 1, k + 1, s & v(k) & "|"
       
    'Recorre novamente a partir do elemento anterior:
        Combina
    ção n, p, k + 1, s
       
    End Sub
    Function funVerificaPermitacao(strSequencia As String) as Boolean
     
      funVerificaPermitacao
    = False
     
     
    Dim arrValores() As String
     
    Dim bytValor As Byte
     
    Dim intDiferenca As Integer
     
     
    Dim intSoma As Integer
     
    Dim blnEstaEmSequencia As Boolean
     
     
    Dim bytTotalPar As Byte
     
    Dim bytTotalImpar As Byte
     
      arrValores
    = Split(strSequencia, "|")
     
     
      intSoma
    = 0
      bytTotalPar
    = 0
      bytTotalImpar
    = 0
     
      blnEstaEmSequencia
    = False
     
     
    For bytValor = 0 To 5
       
        intSoma
    = intSoma + arrValores(bytValor)
       
       
    If bytValor < 5 Then
         
          intDiferenca
    = CInt(arrValores(bytValor + 1)) - CInt(arrValores(bytValor))
         
         
    If intDiferenca = 1 Then
            blnEstaEmSequencia
    = True
         
    End If
         
       
    End If
       
       
    If arrValores(bytValor) Mod 2 = 0 Then
          bytTotalPar
    = bytTotalPar + 1
       
    Else
          bytTotalImpar
    = bytTotalImpar + 1
       
    End If
       
     
    Next bytValor
     
     
     
     
    '2- Fizesse um teste pra ver se estes números estão em sequência,
     
    'admitindo-se apenas combinações que tenham 2 números em sequência
     
    '(tipo 1,2,5,17,25,32 ou 5,11,25,26,48,52), caso contrário a combinação fosse descartada;
     
    If blnEstaEmSequencia = True Then
       
       
       
    '3- As combinações aproveitadas no passo anterior passarem por um novo teste.
       
    'Somente as sequências cuja soma estejam no intervalo entre 107 e 266 são guardadas,
       
    'as demais excluidas (ex. 5,11,25,26,48,52 => 5+11+25+26+48+52=167 guardar, 1,2,5,17,25,32 => 1+2+5+17+25+32=82 descarta);
       
    If intSoma >= 107 And intSoma <= 266 Then
         
         
    '4-  As combinações aproveitadas no passo anterior passarem por um novo teste.
         
    'Somente as sequências contenham 3 pares e 3 impares, ou 2 pares e 4 impares,
         
    'ou ainda 4 pares e 2 impares são guardadas (ex. 5,11,25,26,48,52, são 3 pares e 3 impares);
         
    If bytTotalPar > 1 And bytTotalImpar > 1 Then
       
            funVerificaPermitacao
    = True 'se passar por todas as verificações, então retorna verdadeiro
       
         
    End If
       
    End If
       
     
     
    End If
         

     
    End Function

    domingo, 26 de julho de 2015 20:20

Respostas

  • Fábio Perdigão,

    A intenção do fórum não seria a de auxílio com problemas de lógica e sim de auxílio com problemas/erros relacionados diretamente a tecnologia selecionada, neste caso VB.NET e Visual Basic. Problemas com lógica de programa não serão tratados aqui.

    Atenciosamente


    Marcos Roberto de Souza Junior

    Esse conteúdo e fornecido sem garantias de qualquer tipo, seja expressa ou implícita

    MSDN Community Support

    Por favor, lembre-se de Marcar como Resposta as respostas que resolveram o seu problema. Essa e uma maneira comum de reconhecer aqueles que o ajudaram e fazer com que seja mais fácil para os outros visitantes encontrarem a resolução mais tarde.

    • Marcado como Resposta Marcos SJ quinta-feira, 10 de dezembro de 2015 18:51
    quinta-feira, 10 de dezembro de 2015 18:51

Todas as Respostas

  • Bom dia Fábio,

    tudo bem?

    Vejo que está com problemas de lógica e não necessariamente com algum erro na linguagem em si. Você quer ajuda com a lógica de como executar estas ações, não é?

    Atenciosamente


    Marcos Roberto de Souza Junior

    Esse conteúdo e fornecido sem garantias de qualquer tipo, seja expressa ou implícita

    MSDN Community Support

    Por favor, lembre-se de Marcar como Resposta as respostas que resolveram o seu problema. Essa e uma maneira comum de reconhecer aqueles que o ajudaram e fazer com que seja mais fácil para os outros visitantes encontrarem a resolução mais tarde.


    • Editado Marcos SJ quarta-feira, 29 de julho de 2015 17:10
    terça-feira, 28 de julho de 2015 13:59
  • Olá, 

    estou adaptando o código para sua solicitação.

    Vale ressaltar que o código original não é de minha autoria, apenas editei pela necessidade do usuário da outra thread.

    Abraço!


    Natan

    terça-feira, 28 de julho de 2015 21:28
  • Olá 'Natan Silva,

    tudo bem?

    Este outro usuário entrou em contato com você através desta outra thread.


    Marcos Roberto de Souza Junior

    Esse conteúdo e fornecido sem garantias de qualquer tipo, seja expressa ou implícita

    MSDN Community Support

    Por favor, lembre-se de Marcar como Resposta as respostas que resolveram o seu problema. Essa e uma maneira comum de reconhecer aqueles que o ajudaram e fazer com que seja mais fácil para os outros visitantes encontrarem a resolução mais tarde.

    quarta-feira, 29 de julho de 2015 17:37
  • Boa noite Natan Agradeço muito sua atenção, e citei você no código para não me apropriar indevidamente do seu ótimo trabalho no código.
    quinta-feira, 30 de julho de 2015 01:23
  • Boa noite Marcos sim é um problema de lógica e mudança na rotina.
    quinta-feira, 30 de julho de 2015 01:26
  • Fábio Perdigão,

    A intenção do fórum não seria a de auxílio com problemas de lógica e sim de auxílio com problemas/erros relacionados diretamente a tecnologia selecionada, neste caso VB.NET e Visual Basic. Problemas com lógica de programa não serão tratados aqui.

    Atenciosamente


    Marcos Roberto de Souza Junior

    Esse conteúdo e fornecido sem garantias de qualquer tipo, seja expressa ou implícita

    MSDN Community Support

    Por favor, lembre-se de Marcar como Resposta as respostas que resolveram o seu problema. Essa e uma maneira comum de reconhecer aqueles que o ajudaram e fazer com que seja mais fácil para os outros visitantes encontrarem a resolução mais tarde.

    • Marcado como Resposta Marcos SJ quinta-feira, 10 de dezembro de 2015 18:51
    quinta-feira, 10 de dezembro de 2015 18:51