none
Como fazer código VBA EXCEL gerar outra planilha quando o resultado excede o limite de linhas? RRS feed

  • Pergunta

  • No Excel o código VBA abaixo gera todas as combinações possíveis da Mega Sena. Só que tem um porém. O numero de combinações excede o limite de linhas do Excel e apenas por conta disso a lista de combinações não fica completa. Gostaria de saber como posso adaptar esse código para que todas as combinações sejam exibidas no Access, ou através de arquivo executável, ou que modificação/inclusão posso fazer para que quando o código for executado automaticamente o excel gere novas planilhas para continar escrevendo as combinações que não couberam na planilha anterior etc etc e assim sucessivamente? ? ?

    Segue o código:

    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 v(1 To 60)

    Sub Teste()
        Dim lElementos As Long
        
        'Popula vetor de elementos
        v(1) = "1"
        v(2) = "2"
        v(3) = "3"
        v(4) = "4"
        v(5) = "5"
        v(6) = "6"
        v(7) = "7"
        v(8) = "8"
        v(9) = "9"
        v(10) = "10"
        v(11) = "11"
        v(12) = "12"
        v(13) = "13"
        v(14) = "14"
        v(15) = "15"
        v(16) = "16"
        v(17) = "17"
        v(18) = "18"
        v(19) = "19"
        v(20) = "20"
        v(21) = "21"
        v(22) = "22"
        v(23) = "23"
        v(24) = "24"
        v(25) = "25"
        v(26) = "26"
        v(27) = "27"
        v(28) = "28"
        v(29) = "29"
        v(30) = "30"
        v(31) = "31"
        v(32) = "32"
        v(33) = "33"
        v(34) = "34"
        v(35) = "35"
        v(36) = "36"
        v(37) = "37"
        v(38) = "38"
        v(39) = "39"
        v(40) = "40"
        v(41) = "41"
        v(42) = "42"
        v(43) = "43"
        v(44) = "44"
        v(45) = "45"
        v(46) = "46"
        v(47) = "47"
        v(48) = "48"
        v(49) = "49"
        v(50) = "50"
        v(51) = "51"
        v(52) = "52"
        v(53) = "53"
        v(54) = "54"
        v(55) = "55"
        v(56) = "56"
        v(57) = "57"
        v(58) = "58"
        v(59) = "59"
        v(60) = "60"
        
        
        '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
    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:
            r = r + 1
            Cells(r, "A").Resize(1, lPermutações) = Split(s, "|")
            'Se quiser visualizar o resultado na Janela de Verificação imediata, use:
            Debug.Print s
            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


    domingo, 14 de setembro de 2014 15:40

Respostas

  • Deverton....

    segue minha manipulação do teu código...

    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 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 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 Then 'aqui se a linha for zero, Set wks = ThisWorkbook.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 r = r + 1 wks.Cells(r, "A").Resize(1, lPermutações) = Split(s, "|") 'Se quiser visualizar o resultado na Janela de Verificação imediata, use: 'Debug.Print s

    If r = 1048576 Then 'se a linha for igual a ultima linha do excel 2007 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



    Natan

    • Marcado como Resposta deverton1818 segunda-feira, 15 de setembro de 2014 15:02
    segunda-feira, 15 de setembro de 2014 01:51

Todas as Respostas

  • Deverton....

    segue minha manipulação do teu código...

    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 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 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 Then 'aqui se a linha for zero, Set wks = ThisWorkbook.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 r = r + 1 wks.Cells(r, "A").Resize(1, lPermutações) = Split(s, "|") 'Se quiser visualizar o resultado na Janela de Verificação imediata, use: 'Debug.Print s

    If r = 1048576 Then 'se a linha for igual a ultima linha do excel 2007 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



    Natan

    • Marcado como Resposta deverton1818 segunda-feira, 15 de setembro de 2014 15:02
    segunda-feira, 15 de setembro de 2014 01:51
  • Valew natan. Funciona perfeitamente.

    Só não consegui obter a lista completa das combinações porque quando chega na planilha grupo 25 a memória RAM do meu PC se esgota. 

    segunda-feira, 15 de setembro de 2014 15:00
  • Natan, boa noite!

    Não entendo nada de macro, logo gostaria de te pedir um help.

    O codigo acima funcionou parcialmente, pois como o colega Deverton1818 disse o PC trava por falta de memória RAM.

    Logo minha dúvida é se seria possível alterar a macro de forma que ao chegar na linha n° 1.000.000 o excel copiasse a série de sequências, colasse especial como valores em uma planilha nova, esta fosse salva com um nome sequencial em uma pasta pré-determinada e a seria copiada fosse apagada?

    Ou ainda, ao chegar a linha n° 1.000.000 o excel abrisse outra planilhe e continuasse a geração das sequências. A planilha que chegou a linha n° 1.000.000 fosse salva em um endereço pré determinado e fechada, de modo que não ocupasse memória...

    Se for possível, por favor, gerar um arquivo da macro e me enviar, pois tenho receio de fazer "merda" e não conseguir rodar a macro.

    Grato

    Fernando

    segunda-feira, 9 de março de 2015 05:36
  • Claro...

    é só pegar o código abaixo e jogar em um módulo..

    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 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 r = r + 1 wks.Cells(r, "A").Resize(1, lPermutações) = Split(s, "|") '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 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



    Natan

    segunda-feira, 9 de março de 2015 13:39
  • Natan, boa tarde!

    Agora quero fazer a coisa ficar dificil...rsrsr

    Você acha que seria muito complexo se:

    1- A macro gerasse a combinação de 6 números;

    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;

    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);

    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); 

    Facil??

    PS: Se no teste 2, o de sequência houver como excluir também as diagonais, tipo 2,13,24,35,46,57, ou 53,43,34,25,16,7 seria ótimo.

    Grato

    Fernando

    segunda-feira, 9 de março de 2015 20:46
  • ohhhh Fernando... se conseguir alguma coisa com isso aqui me paga uma coca depois... XD

    segue....

    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

    PS: me manda a fórmula matemática para identificar as diagonais que eu incluo ela na verificação.

    Abraço!


    Natan


    • Editado 'Natan Silva terça-feira, 10 de março de 2015 01:16
    terça-feira, 10 de março de 2015 01:14
  • Sou novo no assunto, mas estava precisando descobrir como fazer um sistema para gerar no excel automanticamente um anagrama sendo ele

    1,2,3,4,5

    1,2,3,5,4

    1,2,4,3,5

    1,2,4,5,3

    e assim sucessivamente sendo que eu quero fazer com 15 digitos

    1,2,3,4,5,6,7,8,9,10,11,12,13,14,15

    mas para fazer manualmente e muito ruim 

    pois vai ter 1,3 e 12 linhas de anagrama, gostaria de saber se alguem pode me ajudar ou alguem ja fez com mais de 7 numeros 

    como

    1,2,3,4,5,6,7

    qualquer duvida favor entrar direto em contato com o meu email

    robsonregra@gmail.com

    OBRIGADO!


     
    terça-feira, 10 de março de 2015 22:46
  • Parabéns pelo código e pelo disprendimento em disponibilizá-lo . Você tem algum código que : 1 - permiti escolher certo número de dezenas fixas, completa-se as dezenas faltantes para concorrer com a cartela. Ex. 04 fixas e completar 50 2 - filtro Permitisse filtrar certo número de dezenas por linha Ex. De 1 a 10 somente pudesse jogar com 5 dezenas 3 - filtro Permitisse também filtrar certa quantidade de dezenas por final ou seja por coluna 5 - 15 - 25 -35 -45 OBs. Ou seja permitiria jogos somente com 5 em cada linha e 5 em cada coluna e podendo escolher dezenas ( desde que não interferisse no filtro) SeriA para criar cartelas da Lotomania Grato pela atenção
    sexta-feira, 24 de julho de 2015 21:43
  • Boa noite a todos!

    Ficaria imensamente agradecido se alguém puder descrever uma macro que combinasse os números de uma planilha excel. Sei que dependendo da combinação exige-se milhões de linhas. como exemplo envio um pequeno modelo de combinação resolvido: Obrigado!

    1 3 5 7
    2 4 6 8
    1 3 5 7
    1 3 5 8
    1 3 6 7
    1 3 6 8
    1 4 5 7
    1 4 5 8
    1 4 6 7
    1 4 6 8
    2 3 5 7
    2 3 5 8
    2 3 6 7
    2 3 6 8
    2 4 5 7
    2 4 5 8
    2 4 6 7
    2 4 6

    8

    terça-feira, 28 de julho de 2015 02:57
  • Muito bom o código Natan,

    eu como leigo vau te perguntar se é possivel, nesse mesmo codigo , ao inves de 1 a 60 eu combinar 6 a 6 numeros que eu inserir em algum lugar. Por exemplo, quero que ele combine nessas mesmas condições os numeros (12, 22, 33, 48, 55, 35, 28, 44, 60, 51, 35, 49).

    tem como?

    quinta-feira, 21 de janeiro de 2016 14:07
  • Caro  Natan, não sei se desta forma consigo um acesso teu.

    A algum tempo vi este código e resolvi utilizá-lo. 

    Parabéns, ele roda muito bem...

    Porém recentemente ao executá-lo percebi que ele omite algumas linhas.

    Por exemplo: if intsoma>=213 and <=215, de 1 a 60 números com permutações de 6.

    Eu descobri que ele omite a linha 6-18-34-47-52-57, pulando para 6-18-34-47-54- etc.

    Seria um erro de sistema?

    sexta-feira, 22 de janeiro de 2016 01:55
  • Olá Daniel,

    na verdade não é erro, isso é só uma condição que o colega acima solicitou... onde se a soma dos valores das permutações estivesse entre 213 e 215 essa combinação fosse descartada.

    Pessoal,

    gostaria de informar novamente que o código não é de minha autoria, só ajudei no fórum.

    Abraços!


    Natan

    sexta-feira, 22 de janeiro de 2016 10:17
  • aelric,

    pra fazer isso use o código abaixo:

    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() As String 'As Integer '(1 To 60)
    
    Sub Teste()
    
        Dim lElementos As Long
         
        v = Split("12,22,33,48,55,35,28,44,60,51,35,49", ",")
        
        '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
              
              'MsgBox "Ok"
              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 = True
      Exit Function
      
      funVerificaPermitacao = False
      
      Dim arrValores() As String
      Dim bytValor As Byte
      Dim intDiferenca As Integer
      
      Dim intSoma As Integer
      Dim blnEstaEmSequencia As Boolean
      Dim blnDiagonal_1 As Boolean
      
      Dim bytTotalPar As Byte
      Dim bytTotalImpar As Byte
      
      arrValores = Split(strSequencia, "|")
      
      
      intSoma = 0
      bytTotalPar = 0
      bytTotalImpar = 0
      
      blnEstaEmSequencia = False
      blnDiagonal_1 = True
      
      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
          
          'verifica se existe uma diagonal  2,13,24,35,46,57
          If arrValores(bytValor) + 11 <> arrValores(bytValor + 1) Then
            blnDiagonal_1 = False
          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


    Natan


    • Editado 'Natan Silva sexta-feira, 22 de janeiro de 2016 12:04
    sexta-feira, 22 de janeiro de 2016 12:04
  • Natan, muito bacana o código e a sua disposição em ajudar, Parabéns!

    Estou tentando fazer algo como o aelric28 mencionou (só não preciso eliminar nada), porém quando testo um sequencia, tipo de 1 a 10, as combinações estão iniciando em 2 ao invés de iniciarem em 1.

    Percebi que você comentou o "+1" no trecho: lElementos = UBound(v) - LBound(v) '+ 1. Poderia me dizer o porque?

    Obs.: Mesmo sem alterar nada, mantendo os números do aelric28

    [v =Split("12,22,33,48,55,35,28,44,60,51,35,49", ",") ] está gerando 462 combinações. É por causa das regras de eliminação de algumas combinações? A Fórmula no excel(=COMBIN(12;6)) retorna 924.

    Poderia dar uma ajuda, por favor?

    Desde já, muito obrigado.

    terça-feira, 26 de janeiro de 2016 21:33
  • Olá Intercon,

    na verdade foi uma falha na codificação.

    Quando tentei o split vi que deu erro e não analisei corretamente por isso comentei esse trecho... ele não deve ser comentado, mas a linha da combinação deve ser alterada:

    'de:
    
    Combinação n, p - 1, k + 1, s & v(k) & "|"
    
    'para:
    
    Combinação n, p - 1, k + 1, s & v(k - 1) & "|"

    Isso porque o array agora está começando com 0, e não mais com 1 como estava antes.

    Quanto a quantidade de itens, realmente estava trazendo errado pelo mesmo problema acima... nenhum dos registros gerados fogem às regras de verificação.

    Agora ele gera os 924 registros.

    Abraço!


    • Editado 'Natan Silva quarta-feira, 27 de janeiro de 2016 10:40
    quarta-feira, 27 de janeiro de 2016 10:36
  • Fernando fhvbb, qual lógica você usou para chegar nesses valores: "Somente as sequências cuja soma estejam no intervalo entre 107 e 266"? Por quê exatamente esses números, tem algum significado? Fiquei curioso.

    Abs.

    quinta-feira, 25 de fevereiro de 2016 21:23
  • Prezado, Natan. Obrigado por ter respondido a minha questão anterior. Agora tenho outra dúvida.

    Por que você atribuiu True para a função e depois chama Exit Function? Quando vai executar o restante do código? Se puder ajudar mais uma vez...Muito obrigado. Abs.

    Function funVerificaPermitacao(strSequencia As String) As Boolean
      
      funVerificaPermitacao = True
      Exit Function
      
      funVerificaPermitacao = False


    • Editado JeanBarros sábado, 27 de fevereiro de 2016 05:26
    sábado, 27 de fevereiro de 2016 05:26
  • Na verdade essa linha era pra estar comentada, isso pra que em modo debug eu não precisar fazer as verificações durante os testes.

    pode comentar esse trecho.


    Natan


    • Editado 'Natan Silva domingo, 28 de fevereiro de 2016 00:06
    sábado, 27 de fevereiro de 2016 11:46
  • Obrigado mais uma vez, Natan.
    terça-feira, 1 de março de 2016 19:12
  • aelric,

    pra fazer isso use o código abaixo:

    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() As String 'As Integer '(1 To 60)
    
    Sub Teste()
    
        Dim lElementos As Long
         
        v = Split("12,22,33,48,55,35,28,44,60,51,35,49", ",")
        
        '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
              
              'MsgBox "Ok"
              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 = True
      Exit Function
      
      funVerificaPermitacao = False
      
      Dim arrValores() As String
      Dim bytValor As Byte
      Dim intDiferenca As Integer
      
      Dim intSoma As Integer
      Dim blnEstaEmSequencia As Boolean
      Dim blnDiagonal_1 As Boolean
      
      Dim bytTotalPar As Byte
      Dim bytTotalImpar As Byte
      
      arrValores = Split(strSequencia, "|")
      
      
      intSoma = 0
      bytTotalPar = 0
      bytTotalImpar = 0
      
      blnEstaEmSequencia = False
      blnDiagonal_1 = True
      
      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
          
          'verifica se existe uma diagonal  2,13,24,35,46,57
          If arrValores(bytValor) + 11 <> arrValores(bytValor + 1) Then
            blnDiagonal_1 = False
          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


    Natan


    Olá Natan, parabéns pelas soluções que voce propós, todas funcionam, voce mencionou que não criou o código, mas eu queria saber se com ele é possível gerar jogos buscando em uma tabela a quantidade de vezes que cada numero deverá aparecer em cada uma das 6 casas?
    sábado, 2 de abril de 2016 00:29
  • Boa tarde, pessoal.

    Como demora dias para rodar todas as combinações, como seria possível continuar a rodar do ponto que parou se der algum problema como tela azul, reiniciar por atualização, travar o pc, etc.. isso sabendo a última combinação "s" gerada?

    obrigado

    quarta-feira, 15 de junho de 2016 15:25
  • Olá pessoal,

        Ao invés de gerar todas as combinações como poderia limitar uma quantidade, ou seja, gerar uma quantidade de combinações??? somando os numeros.... a soma total não ultrapassem um total especificado.

    tipo

    10 combinação

    com a soma total dos numeros igual a 15 ou outro valor????  

    sexta-feira, 28 de outubro de 2016 18:50
  • Olá Natan!

    Eu vi o tópico em que você ajudou uma pessoa.

    Estou escrevendo depois de algum tempo, pois começei a editar o código agora e estou tendo dificuldade. Vi que seu perfil ainda é ativo e por isso resolvi entrar em contato.

    A ideia do código é fazer combinações sem repeticão e formar grupo de combinações de 16 números.

    Porém, quero que a macro pegue esses 20 números na Coluna A e o 16 na célula B2.

    Abaixo segue o mesmo código que disponibilizou no passado com as ideias que não estão funcionando.

    Se puder ajudar, ficarei feliz.

    Option Explicit
    
    'C(n, p) = n! / ((n-p)! * p!)
    'lPermutações a ser definido, seria o 'p' da fórmula acima
    
    'Declara Variáveis
    
    Const lPermutações As Long = Comb 'Quantidade de números em cada grupo
    Dim r As Long
    Dim wkb As Workbook
    Dim wks As Worksheet
    Dim ws1 As Worksheet
    Dim UltimaLinha1 As Long
    Dim Valor1() As Variant
    Dim intGrupo As Integer
    Dim Comb As Integer
    Dim x As Byte 'apenas um contador para o laço
    Dim v(Valor1 To UltimaLinha1) 'Pegar os números da Coluna A e fazer a combinações entre eles, respeitando a quantidade do grupo.
    
    
    Sub Teste()
        Dim lElementos As Long
    
        'Última linha da coluna A de cada Planilha
        Set ws1 = ThisWorkbook.Sheets("Filtro")
        Comb = ws1.Range("B1").Value
        UltimaLinha1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
        Valor1 = ws1.Range("A1:A" & UltimaLinha1).Value
    
        'Popula vetor de elementos
        For x = Valor1 To UltimaLinha1    '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 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
    
            r = r + 1
            wks.Cells(r, "A").Resize(1, lPermutações) = Split(s, "|")
            '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
                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


    • Editado Edu.Carvalho domingo, 2 de setembro de 2018 04:04 Correção de valor
    domingo, 2 de setembro de 2018 04:02