Métodos De Apostar (5)

[Edgard Rocha]

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

 

[CRodrigues]

Parabéns pela postagem!
Muito útil mesmo!