Se você tem alguma dica, truque ou macete e gostaria de compartilhar conosco, utilize essa seção.
Por ronierobson 29 Jul 2017 às 00:38
Membro Novato
Mensagens: 3
Reputação: 0
#25114
Saudações.
Como mencionei em minha apresentação, sou novo, tanto no fórum quanto na utilização do Excel.
Bem. Estou desenvolvendo uma planilha para analisar o jogo da Lotofácil, enquanto garimpava pela rede, me deparei com uma planilha onde é possível geral (a partir da: quantidade de dezenas informada para o jogo) e (quantidade de dezenas que se quer utilizar para as combinações), todas as combinações possíveis para um determinado tipo de jogo. Exemplo: Mega Sena, Quina, Lotofácil, etc.
O código é esse:

Public ss As String
Sub Combinações(Optional v As Variant) 'nome da macro é combinação setando a matriz v como variante
Dim n As Integer, m As Integer 'seta a quantidade elementos como número inteiro

n = Application.CountA(Range("A2:XFD2")) 'conta quantidade de números para gerar combinações
If IsMissing(v) Then 'v sendo ausente executa o redimensionamento da matriz na quantidade máxima de 1000 elementos
ReDim v(1000) As Variant
For i = 0 To n - 1 'inicia a captura dos números digitados para a matriz
v(i) = Cells(2, i + 1)
Next
End If
ReDim Preserve v(1 To n) 'redimensiona a matriz para a quantidade máxima de elementos digitados
m = [a4] 'alimente a variável m com a a quantidade de elementos em cada combinação
If m > n Then Exit Sub 'se o número de elementos para combinação for maior que a quantidade de elementos é encerrado a macro

If Application.Combin(n, m) > 100000 Then 'cálcula quantas combinações são possíveis e encerra a macro se foram maior que 100 mil
MsgBox "Serão mais de 100000 combinações, a programação será encerrada"
Exit Sub
End If
ss = "" 'variável ss serve para fazer a junção da combinação
Range("5:5").ClearContents 'seleciona o cabeçalho das combinações e apaga
For i = 1 To m
Cells(5, i) = "Nº " & i 'cria novos cabeçalhos com a quantidade exata dos elementos
Next
Cells(5, i) = "Junção"
Rows("6:1000006").ClearContents 'exclui dados antigos caso existam
Range("A6").Select 'marca a celula inicial que receberá os dados
Comb2 n, m, 1, "", v 'chama a macro Comb2 setando a algumas variáveis e mantendo outras
End Sub

Sub Comb2(ByVal n As Integer, ByVal m As Integer, _
ByVal k As Integer, ByVal s As String, v As Variant)
Dim v1 As Variant
If m > n - k + 1 Then Exit Sub 'se o número de elementos para combinação for maior que a quantidade de elementos é encerrado a macro
If m = 0 Then 'quando m for igual a 0 inicia a montagem das combinações
v1 = Split(Replace(Trim(s), "'", ""), " ") 'v1 armazena a posição que serão recuperados da matriz
sss = "" 'sss assim como ss são utilizadas para a junção dos números da combinação
For i = LBound(v1) To UBound(v1) 'loop da matriz v1 que possui o endereço do elemento da matriz v
sss = sss & v(v1(i)) & " " 'inicia a junção da combinação para apresentar na coluna Junção
ActiveCell.Offset(0, i) = v(v1(i)) 'imprime o primeiro número da combinação na célula A6 sendo incrementada a cada loop
Next
ActiveCell.Offset(0, [a4]) = sss 'imprime na coluna junção os número concatenados
ActiveCell.Offset(1, 0).Select 'seleciona um nova lina
ss = ss & sss & vbNewLine 'limpa conteúdo das variáveis ss e sss
Exit Sub
End If
Comb2 n, m - 1, k + 1, s & k & " ", v 'incrementa as variáveis m utilizada para dar start nas combinações e variável s que armazena o caminho dos elementos da matriz
Comb2 n, m, k + 1, s, v 'quando elimina cada bloco de combinação reinicia a Macro Comb2 até que m seja maior que n
End Sub

Tenho a planilha em meu arquivo, mas não sei como anexá-la aqui. Caso alguém tenha interesse, basta me dizer como e terei prazer em compartilha-la.