Jump to content

Edgard Rocha

Membro Inativo
  • Posts

    5
  • Joined

  • Last visited

Recent Profile Visitors

2,699 profile views

Edgard Rocha's Achievements

Apprentice

Apprentice (3/14)

  • First Post
  • Conversation Starter
  • Week One Done
  • One Month Later
  • One Year in

Recent Badges

6

Reputation

  1. FAIXAS ARBITRÁRIAS Uma variante do método anterior: pode-se estabelecer uma quantidade maior de faixas de distribuição, sete por exemplo. Em lugar de calcular a média, acham-se a maior e a menor contagem em cada sorteio, divide-se esse intervalo em sete faixas iguais e distribuem-se as dezenas pelas mesmas. O resto é igual. ' OBS.1: jogo estudado - Mega Sena ' OBS.2: foi feita a colagem na planilha, apenas das 6 colunas que interessam (dezenas) Type tCnt Dez As Integer Cnt As Integer End Type Dim d(1 To 60) As tCnt ' dezenas Type tCfg Img As String Cnt As Integer End Type Dim c(1 To 924) As tCfg ' configs Type tFxa Lim As Integer Cnt As Integer Fin As String End Type Dim f(1 To 8) As tFxa ' faixas Sub Main() Dim x, prijogo, ultjogo As Integer ultjogo = ActiveCell.SpecialCells(xlLastCell).Row For x = 1 To 16 prijogo = Worksheets(1).Cells(x, 9).Value Call CriaJogo(x, prijogo, ultjogo) Next x End Sub Sub CriaJogo(ByVal ppj As Integer, ByVal pj As Integer, uj As Integer) Dim w, x, y, z As Integer Dim f1, f2, f3, f4, f5, f6, f7 As Integer ' inicializar ' dezenas For x = 1 To 60 d(x).Dez = x d(x).Cnt = 0 'd(x).Fxa = 0 Next x ' configs z = 0 For f1 = 0 To 6 For f2 = 0 To 6 For f3 = 0 To 6 For f4 = 0 To 6 For f5 = 0 To 6 For f6 = 0 To 6 For f7 = 0 To 6 ' so config validas If f1 + f2 + f3 + f4 + f5 + f6 + f7 = 6 Then z = z + 1 c(z).Img = f1 & "," & f2 & "," & _ f3 & "," & f4 & "," & _ f5 & "," & f6 & "," & f7 c(z).Cnt = 0 End If Next f7: Next f6: Next f5 Next f4: Next f3: Next f2: Next f1 Dim j(1 To 6) As Integer Dim gap As Integer Dim cfg As String For x = pj To uj ' obter as dezenas For y = 1 To 6 j(y) = Worksheets(1).Cells(x, y).Value Next y ' calc interv das faixas f(1).Lim = 9999 f(8).Lim = -1 For y = 1 To 60 If f(8).Lim < d(y).Cnt Then f(8).Lim = d(y).Cnt If f(1).Lim > d(y).Cnt Then f(1).Lim = d(y).Cnt Next y z = (f(8).Lim - f(1).Lim) gap = DivPor7(z) If gap > 0 Then ' distrib as dezenas ANTES da contagem For y = 1 To 7 If y > 1 And y < 6 Then f(y).Lim = f(y - 1).Lim + gap f(y).Cnt = 0 f(y).Fin = Space(0) Next y f(8).Lim = f(8).Lim + 1 For y = 1 To 6 w = j(y) For z = 1 To 7 If d(w).Cnt >= f(z).Lim And d(w).Cnt < f(z + 1).Lim Then f(z).Cnt = f(z).Cnt + 1 Exit For End If Next z Next y ' desenhar a config cfg = Space(0) For y = 1 To 7 cfg = cfg & f(y).Cnt If y < 7 Then cfg = cfg & "," Next y ' contar a config For y = 1 To 924 If cfg = c(y).Img Then c(y).Cnt = c(y).Cnt + 1 Exit For End If Next y End If ' contar as dezenas For y = 1 To 6 w = j(y) d(w).Cnt = d(w).Cnt + 1 Next y Next x ' distrib final de todas as dez For x = 1 To 60 For y = 1 To 7 If d(x).Cnt >= f(y).Lim And d(x).Cnt < f(y + 1).Lim Then 'd(x).Fxa = y f(y).Fin = f(y).Fin & d(x).Dez & "," Exit For End If Next y Next x ' exibir a distrib final For x = 1 To 7 cfg = f(x).Fin z = Len(cfg) ' elim ult virg If z > 0 Then f(x).Fin = Left(cfg, z - 1) Worksheets(1).Cells(ppj, x + 9).Value = f(x).Fin Next x ' ordenar as config Dim aux As tCfg For x = 1 To 923 For y = (x + 1) To 924 If c(x).Cnt < c(y).Cnt Then aux = c(x) c(x) = c(y) c(y) = aux End If Next y Next x ' exibir só as melhores config For x = 1 To 9999 Worksheets(1).Cells(ppj + 17, x + 9).Value = c(x).Img If c(x).Cnt < c(1).Cnt Then Exit For Next x Columns("J:P").EntireColumn.AutoFit End Sub Function DivPor7(ByVal n As Integer) As Integer ' mais prox interv div por 7 Dim x As Integer For x = 0 To 6 If (n + x) Mod 7 = 0 Then n = n + x Exit For ElseIf (n - x) > 0 And (n - x) Mod 7 = 0 Then n = n - x Exit For End If Next x DivPor7 = n \ 7 End Function
  2. FAIXAS ACIMA, ABAIXO E NA MÉDIA Baseia-se na constatação de que não saem sempre as dezenas mais freqüentes, mas sim uma mistura de situações. Funciona assim: em cada sorteio, antes de contar as dezenas, determinar a média das contagens até o momento, separar as contagens em 3 faixas: na média, abaixo e acima da média. Encaixar as dezenas do sorteio na faixa onde se encontram (por exemplo, se for a MegaSena, 2 acima, 1 na média e 3 abaixo), formando assim uma combinação (2-1-3 no exemplo) que deve ser contada, juntamente com as dezenas. Antes de ler o próximo sorteio, não esquecer de incluir as dezenas do atual na contagem, porque a formação da combinação é feita antes de se contar as dezenas. Para não incluir resultados irreais, só começar a contar as combinações formadas após todas as dezenas haverem saído ao menos uma vez. No fim dos resultados, distribuir todas as dezenas conforme a faixa e apostar na combinação mais freqüente. São possíveis varias apostas. (Continuando com a combinação 2-1-3 do exemplo, pegar 2 das dezenas com contagem acima da média, uma bem na média e três abaixo.) Com relação às dezenas acima e abaixo, podem-se apostar as mais próximas da média, as mais distantes, etc. ' OBS.1: jogo estudado – MegaSena ' OBS.2: já foi feita a colagem na planilha, usando Dados/De Texto e ignorando outras colunas que não as Dezenas Type tCnt Dez As Integer Cnt As Integer 'Fxa As Integer ' usada apenas no debug End Type Dim d(1 To 60) As tCnt ' dezenas Type tCfg Img As String Cnt As Integer End Type Dim c(1 To 28) As tCfg ' configs Type tFxa Cnt As Integer Fin As String End Type Dim f(1 To 3) As tFxa Sub Main() Dim x, prijogo, ultjogo As Integer ultjogo = ActiveCell.SpecialCells(xlLastCell).Row For x = 1 To 16 prijogo = Worksheets(1).Cells(x, 9).Value If IsEmpty(prijogo) Then prijogo = 1 Else prijogo = CInt(prijogo) End If Call CriaJogo(x, prijogo, ultjogo) Next x End Sub Sub CriaJogo(ByVal ppj As Integer, ByVal pj As Integer, uj As Integer) Dim w, x, y, z As Integer Dim f1, f2, f3 As Integer ' inicializar ' dezenas For x = 1 To 60 d(x).Dez = x d(x).Cnt = 0 'd(x).Fxa = 0 Next x ' configs z = 0 For f1 = 0 To 6 For f2 = 0 To 6 For f3 = 0 To 6 ' só config válidas If f1 + f2 + f3 = 6 Then z = z + 1 c(z).Img = f1 & "," & f2 & "," & f3 c(z).Cnt = 0 End If Next f3: Next f2: Next f1 Dim j(1 To 6) As Integer Dim cfg As String For x = pj To uj ' obter as dezenas For y = 1 To 6 j(y) = Worksheets(1).Cells(x, y).Value Next y ' calc interv das faixas z = 0 For y = 1 To 60 z = z + d(y).Cnt Next y z = z \ 60 ' distrib as dezenas ANTES da contagem For y = 1 To 6 w = j(y) If d(w).Cnt < z Then f(1).Cnt = f(1).Cnt + 1 ElseIf d(w).Cnt > z Then f(3).Cnt = f(3).Cnt + 1 Else f(2).Cnt = f(2).Cnt + 1 End If Next y ' desenhar a config cfg = Space(0) For y = 1 To 3 cfg = cfg & f(y).Cnt If y < 3 Then cfg = cfg & "," Next y ' contar a config For y = 1 To 28 If cfg = c(y).Img Then c(y).Cnt = c(y).Cnt + 1 Exit For End If Next y ' contar as dezenas For y = 1 To 6 w = j(y) d(w).Cnt = d(w).Cnt + 1 Next y Next x ' distrib final de todas as dezs For x = 1 To 60 If d(x).Cnt < mda Then f(1).Fin = f(1).Fin & x & "," ElseIf d(x).Cnt > mda Then f(3).Fin = f(3).Fin & x & "," Else f(2).Fin = f(2).Fin & x & "," End If Next x ' exibir a distrib final For x = 1 To 3 cfg = f(x).Fin z = Len(cfg) ' elim ult virg If z > 0 Then f(x).Fin = Left(cfg, z - 1) Worksheets(1).Cells(ppj, x + 9).Value = f(x).Fin Next x ' ordenar as config Dim aux As tCfg For x = 1 To 27 For y = (x + 1) To 28 If c(x).Cnt < c(y).Cnt Then aux = c(x) c(x) = c(y) c(y) = aux End If Next y Next x ' exibir so as melhores config For x = 1 To 28 Worksheets(1).Cells(ppj + 17, x + 9).Value = c(x).Img If c(x).Cnt < c(1).Cnt Then Exit For Next x Columns("J:P").EntireColumn.AutoFit MsgBox “O.K.” End Sub 'Sub lixo() 'saber qtd de cfg validas p/ inicializar array 'Dim x, f1, f2, f3 As Integer ' z = 0 ' For f1 = 0 To 6 ' For f2 = 0 To 6 ' For f3 = 0 To 6 ' If f1 + f2 + f3 = 6 Then z = z + 1 ' Next f3: Next f2: Next f1 ' MsgBox (z) 'End Sub
  3. COMBINAÇOES POR LINHA DO ESQUEMA Digo linhas do esquema, para diferenciar das linhas do arquivo de resultados, que são os sorteios. Aqui vamos usar a Loto Fácil. Imaginar o volante como uma matriz de cinco linhas com cinco dezenas cada linha. Essas linhas, inicializadas como Strings de cinco espaços (Chr 32 ou 20h), recebem um asterisco na posição correspondente a cada dezena sorteada: forma-se assim, por linha, uma combinação que pode ser contada. Há duas possibilidades de fazer a contagem (variantes do método, que darão resultados diferentes, claro): GERAL, que dá uma estatística das combinações mais freqüentes em geral; ou POR LINHA, o que dá um detalhamento por linha. (Dica: em lugar de espaços e asteriscos, pode-se usar “0”s e “1”s, cada combinação se tornando um binário, que pode ser convertido para um decimal entre 0 e 31 que dá o próprio índice da matriz de contagem.) Ao final da contagem, formar seqüências de cinco combinações em que haja exatamente quinze dezenas assinaladas com asteriscos ou “1”s. ' OBS.1: jogo estudado – Loto Facil ' OBS.2: já foi feita a colagem na planilha, usando Dados/De Texto e ignorando outras colunas que não as Dezenas ‘ OBS.3: tb é gerado um arquivo de saída: "Jogos-LF-aaaa-mm-dd.txt" Type tCmb Img As String Cnt As Integer End Type Dim Cmb(1 To 5, 0 To 31) As tCmb Sub Main() Dim x, jogo, n, ln As Integer Dim p1, p2, p3, p4, p5 As Integer Dim ult As Long Dim c, s As String ' inicialização Columns("R:T").ClearContents Columns("W:W").ClearContents For p1 = 0 To 1 For p2 = 0 To 1 For p3 = 0 To 1 For p4 = 0 To 1 For p5 = 0 To 1 For x = 1 To 5 s = p1 & p2 & p3 & p4 & p5 n = BinToDec(s) Cmb(x, n).Img = s Cmb(x, n).Cnt = 0 Next x Next p5 Next p4 Next p3 Next p2 Next p1 ' contagem das combin ult = UltLin For jogo = 1 To ult s = String(25, "0") For x = 1 To 15 n = Cel(jogo, x) Mid(s, n, 1) = "1" Next x For x = 1 To 25 Step 5 c = Mid(s, x, 5) Select Case x Case 1 Call Contar(1, c, Cmb) Case 6 Call Contar(2, c, Cmb) Case 11 Call Contar(3, c, Cmb) Case 16 Call Contar(4, c, Cmb) Case 21 Call Contar(5, c, Cmb) End Select Next x Next jogo Call Ordenar(Cmb()) ' exibir as combin contadas ln = 0 For x = 1 To 5 For n = 0 To 31 ln = ln + 1 Worksheets(1).Cells(ln, 18).Value = x Worksheets(1).Cells(ln, 19).Value = Cmb(x, n).Img Worksheets(1).Cells(ln, 19).NumberFormat = "00000" Worksheets(1).Cells(ln, 20).Value = Cmb(x, n).Cnt Next n Next x ' exibir os melhores jogos feitos Call Exibir(Cmb()) End Sub Sub Contar(ByVal linha As Integer, ByVal comb As String, ByRef a() As tCmb) Dim x As Integer For x = 0 To 31 If comb = a(linha, x).Img Then a(linha, x).Cnt = a(linha, x).Cnt + 1 Exit Sub End If Next x End Sub Sub Ordenar(ByRef a() As tCmb) ' ordenar mantendo o grup por linha Dim linha, x, y As Integer Dim aux As tCmb For linha = 1 To 5 For x = 0 To 30 For y = (x + 1) To 31 If a(linha, x).Cnt < a(linha, y).Cnt Then aux = a(linha, x) a(linha, x) = a(linha, y) a(linha, y) = aux End If Next y Next x Next linha End Sub Sub Exibir(ByRef a() As tCmb) Dim linha As Long Dim p1, p2, p3, p4, p5 As Integer Dim m(1 To 5) As Integer Dim x, n As Integer Dim r, s As String For x = 1 To 5 ' contagem media da linha m(x) = WorksheetFunction.Average( _ a(x, 0).Cnt, a(x, 31).Cnt) n = 0 ' pos no array da menor contagem usada Do While a(x, n).Cnt > m(x) n = n + 1 Loop m(x) = n Next x s = "Jogos-LF-" & Format(Date, "yyyy-mm-dd") & ".txt" Open s For Output As #1 linha = 0 For p1 = 0 To m(1) For p2 = 0 To m(2) For p3 = 0 To m(3) For p4 = 0 To m(4) For p5 = 0 To m(5) 'For x = 1 To 5 's = a(x, p1).Img & a(x, p2).Img & a(x, p3).Img & _ ' a(x, p4).Img & a(x, p5).Img s = a(1, p1).Img & a(2, p2).Img & a(3, p3).Img & _ a(4, p4).Img & a(5, p5).Img If Com15(s) Then linha = linha + 1 r = Space(0) For n = 1 To 25 If Mid(s, n, 1) = "1" Then r = r & n & "," Next n r = Mid(r, 1, Len® - 1) If linha <= 500 Then _ Worksheets(1).Cells(linha, 23).Value = r Print #1, r End If 'Next x Next p5 Next p4 Next p3 Next p2 Next p1 Close (1) End Sub Function Cel(ByVal Lin As Integer, ByVal col As Integer) As Integer Cel = Worksheets(1).Cells(Lin, col).Value End Function Function UltLin() As Long 'UltLin = ActiveCell.SpecialCells(xlLastCell).Row Dim x As Long Dim v As Integer For x = 1 To 9999 v = Cel(x, 1) If v = 0 Then UltLin = x - 1 Exit Function End If Next x End Function Function Com15(ByVal comb As String) As Boolean Dim x, t As Integer t = 0 For x = 1 To 25 If Mid(comb, x, 1) = "1" Then t = t + 1 Next x If t = 15 Then Com15 = True Else Com15 = False End If End Function Function BinToDec(ByVal b As String) As Integer Dim x, n, p As Integer n = 0 p = 16 Do While Len( < 5 b = "0" & b Loop For x = 1 To 5 If Mid(b, x, 1) = "1" Then n = n + p p = p \ 2 Next x BinToDec = n End Function
  4. PARES ANTES-DEPOIS O segundo método é contar quantas vezes cada dezena foi sorteada depois da anterior, isto é, contar os pares constituídos de atual/seguinte, em cada sorteio, exceto claro, a ultima dezena que não tem seguimento. Tomando por exemplo a Quina, computar em cada sorteio: 1ª/2ª, 2ª/3ª, 3ª/4ª e 4ª/5ª. Dá para notar que é preciso um arquivo por ordem de sorteio. Ao final, iniciar a aposta pelo par que mais saiu, seguido pelo par iniciado pela 2ª dezena do anterior, e assim ir unindo os pares como num dominó. Mas pode acontecer que, em um novo par acrescentado à seqüência, se repita uma dezena que já está na seqüencia – nesse caso, pegar o próximo para que inicie pela mesma dezena anterior. ' OBS.1: jogo estudado - Quina ' OBS.2: este exemplo dá uma facilidade adicional: pode-se indicar na 9ª coluna ("I") o 1º sorteio a partir do qual será feita a contagem (os anteriores são ignorados); o valor default é 1 Type tPar d1 As Integer d2 As Integer cnt As Integer End Type Dim Par(1 To 80, 1 To 80) As tPar Sub Main() Dim x, prijogo, ultjogo As Integer ultjogo = ActiveCell.SpecialCells(xlLastCell).Row For x = 1 To 16 prijogo = Worksheets(1).Cells(x, 9).Value If IsEmpty(prijogo) Then prijogo = 1 Else prijogo = CInt(prijogo) End If Call CriaJogo(x, prijogo, ultjogo) Next x End Sub Sub CriaJogo(ByVal ppj As Integer, ByVal pj As Integer, uj As Integer) Dim x, y, z As Integer Dim p1, p2 As Integer ' iniciar array For x = 1 To 80 For y = 1 To 80 With Par(x, y) .d1 = x .d2 = y .cnt = 0 End With Next y Next x ' computar pares de cada jogo For x = pj To uj Call ContaPar(x, 1, 2) Call ContaPar(x, 2, 3) Call ContaPar(x, 3, 4) Call ContaPar(x, 4, 5) Next x ' ordenar array mantendo 1ª dez do par Dim aux As tPar For x = 1 To 80 ' ordenar Par(x) For y = 1 To 79 For z = (y + 1) To 80 If Par(x, y).cnt < Par(x, z).cnt Then aux = Par(x, y) Par(x, y) = Par(x, z) Par(x, z) = aux End If Next z Next y Next x ' achar par mais ocorrido na estatística z = 1 For x = 2 To 80 If Par(x, 1).cnt > Par(z, 1).cnt Then z = x Next x ' criar jogo iniciado pelo par da 1ª dez Dim j(1 To 5) As Integer j(1) = Par(z, 1).d1 j(2) = Par(z, 1).d2 For x = 3 To 5 z = 1 Do j(x) = Par(j(x - 1), z).d2 If JaTem(j, x) Then ' tentar pares seguintes da mesma dezena z = z + 1 Else Exit Do End If Loop Next x For x = 1 To 5 Worksheets(1).Cells(ppj, x + 9).Value = j(x) Next x MsgBox “O.K.” End Sub Sub ContaPar(ByVal j As Integer, ByVal p1 As Integer, ByVal p2 As Integer) ' contar +1 para o par passado ' recebe as pos, muda para as dezenas corresp p1 = Worksheets(1).Cells(j, p1).Value p2 = Worksheets(1).Cells(j, p2).Value Par(p1, p2).cnt = Par(p1, p2).cnt + 1 End Sub Function JaTem(ByRef a() As Integer, ByVal u As Integer) As Boolean ' comparar elems anters do array com o ultimo Dim x As Integer JaTem = False For x = 1 To (u - 1) If a(x) = a(u) Then JaTem = True Next x End Function Variante: PARES QUAISQUER – TERNOS QUAISQUER Desconsiderando a ordem de sorteio, contar todos os pares que possam ser formados com as dezenas de cada sorteio. Outra variante seria usar ternos ao invés de pares, mas não vale a pena trabalhar com grupos ainda maiores como quadras ou quinas, pois a freqüência de sorteio vai na razão inversa do tamanho.
  5. OBS.: a linguagem usada nos exemplos é o VBA para Excel. MAIS FREQUENTES O método mais simples, claro, é contar todas as dezenas que já saíram e escolher as mais (ou menos) freqüentes. ' OBS.1: jogo estudado - Quina ' OBS.2: já foi feita a colagem na planilha, usando Dados/De Texto e ignorando outras colunas que não as Dezenas Type tipada Dez As Integer Qtd As Integer End Type Dim Censo(1 To 80) As tipada Sub Main() Dim x, n, ult As Integer Dim rng As String For ult = 1 To 16380 If Trim(Worksheets(1).Cells(ult, 1).Text) = Space(0) Then Exit For Next ult rng = "A1:E" & u For Each c In Worksheets(1).Range(rng).Cells n = CInt(c.Value) Censo(n).Dez = n Censo(n).Qtd = Censo(n).Qtd + 1 Next c For x = 1 To 80 Worksheets(1).Cells(x, 8) = Censo(x).Dez Worksheets(1).Cells(x, 9) = Censo(x).Qtd Next x MsgBox "O.K." End Sub
×
×
  • Create New...