Edgard Rocha Posted July 23, 2014 Share Posted July 23, 2014 FAIXAS ACIMA, ABAIXO E NA MÉDIABaseia-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 debugEnd TypeDim d(1 To 60) As tCnt ' dezenas Type tCfg Img As String Cnt As IntegerEnd TypeDim c(1 To 28) As tCfg ' configs Type tFxa Cnt As Integer Fin As StringEnd TypeDim 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 xEnd Sub Sub CriaJogo(ByVal ppj As Integer, ByVal pj As Integer, uj As Integer)Dim w, x, y, z As IntegerDim f1, f2, f3 As Integer ' inicializar' dezenasFor x = 1 To 60 d(x).Dez = x d(x).Cnt = 0 'd(x).Fxa = 0Next x' configsz = 0For f1 = 0 To 6For f2 = 0 To 6For 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 IfNext f3: Next f2: Next f1 Dim j(1 To 6) As IntegerDim 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 yNext x ' distrib final de todas as dezsFor 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 IfNext x ' exibir a distrib finalFor 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).FinNext x ' ordenar as configDim aux As tCfgFor 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 yNext x ' exibir so as melhores configFor x = 1 To 28 Worksheets(1).Cells(ppj + 17, x + 9).Value = c(x).Img If c(x).Cnt < c(1).Cnt Then Exit ForNext xColumns("J:P").EntireColumn.AutoFitMsgBox “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 1 Quote Link to comment Share on other sites More sharing options...
CRodrigues Posted July 23, 2014 Share Posted July 23, 2014 Parabéns pela postagem!Muito útil mesmo! Quote Link to comment Share on other sites More sharing options...
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.