anlyse trés longue

[jad73]

bonjour le forum

je fais une analyse sur les quartés, j'en ai 102510 et avec excel 2010 il me faut environ 50 minutes avec cette formule.
Quelqu'un connaitrait-il une autre façon d'aller plus vite ou un autre programme.
merci

 

[bbb38]

Re : anlyse trés longue

Bonjour Jad73, le forum,
Quelle formule ? Combien de cellules analysées ? Sans un fichier d’exemple, difficile de te répondre (avis personnel). On peut essayer de faire des tests sur quelques lignes pour voir le gain de temps.
Cordialement,
Bernard

 

[jad73]

Re : anlyse trés longue

bonjour bbb38, le forum

voici un bout de fichier joint.
je fais le calcul sur environ 102000 quartés, il y en a 916895.
La BdD fait 10400 lignes.
Quand à la formule ici en Feuil2 col E j'avais déjà fait des recherches mais je n'ai pas trouvé d'amélioration.

merci

 

[R@chid]

Re : anlyse trés longue

Bonjour @ tous,
Moi aussi j'ai pas compris que veux tu faire, une explication vaut mieux qu'une formule
@ + +

 

[JJ1]

Re : anlyse trés longue

Bonjour,

Si j'ai bien compris, tu souhaites étudier la présence d'un quarté dans une base Keno.

Il y a beaucoup de combinaisons d'où la durée importante.
Je vais t'envoyer un fichier.

a+

 

[JJ1]

Re : anlyse trés longue

Bonjour,

Si j'ai bien compris, tu souhaites étudier la présence d'un quarté dans une base Keno.

Il y a beaucoup de combinaisons d'où la durée importante.

Le fichier joint est pour 2 nombres avec le nombre de paires et l'écart.
Modifier les ' dans la macro pour 4 nombres en prévoyant Excel 2007 pour ......916000 lignes.



a+

 

[KenDev]

Re : anlyse trés longue

Bonjour à tous,

Une approche différente qui travaille directement sur les fichiers historiques fournis par la fdj et suit tous les quartés :

Le fichier pèse 13,5 Mo et contiendra toujours 916 895 cellules sans formules contre, selon le classeur exemple fourni :
_ Si on veut suivre tous les quartés : 916895 * 5 + 10422 * 22 = 4 813 759 cellules (+ 44 chaque jour) dont 916 895 formules matricielles
_ Si on ne suit 'que' 102510 (post 1) : 102510 * 5 + 10422 * 22 = 512 550 cellules (+ 44 chaque jour) dont 102 510 formules matricielles


Le résultat est, sur une nouvelle feuille, une seule colonne de 916895 lignes contenant le nombre d'apparitions à ce jour du quarté correspondant à sa ligne. En C2 apparait le n0 du dernier tirage (exemple : 2013108), utile pour l'actualisation ultérieure.

Pour ensuite récupérer le quarté correspondant à une ligne n, utiliser la fonction :

=NCmbTxt(70;4;n)

.

La 1ère sub est longue mais à usage unique. L'avancement du travail est indiqué dans la status bar (cible à 10422 actuellement )

Mode d'emploi :

Opération unique : Placer le classeur et les deux fichiers csv (keno.csv & keno_gagnant_a_vie.csv) dans le même dossier et lancer la sub Jad73Q.

Actualisation : Mettre à jour keno_gagnant_a_vie.csv dans le dossier et lancer - depuis la feuille obtenue précédement - la sub Jad73QActua .

Cordialement

KD

Option Explicit

Sub Jad73Q()
    Dim Ff%, Ch$, a$, b$(), Ta&(), Tb&(), i&, j&, Tc&(1 To 916895), k As Byte, Fn$(1), n&, Ag$  '916895=nb de combinaisons de 4 parmi 70
    Application.Calculation = xlCalculationManual
    Fn(0) = "keno_gagnant_a_vie.csv": Fn(1) = "keno.csv"                                        'nom des fichiers sources, + récent en premier
    Ta = CmbN(20, 4)                                                                            'liste des combinaisons de 4 parmi 20
    ReDim Tb(4)                                                                                 'quarté en cours à incrémenter (tb(0)=0)
    For k = 0 To 1
        Ch = ThisWorkbook.Path & "\" & Fn(k)                                                    'sources et classeur, même dossier
        LfToCrlf (Ch)                                                                           'sources : de LF vers CRLF
        If k = 0 Then
            Ff = FreeFile
            Open Ch For Input As #Ff                                                            'sources: ordre tirage décroissant
                Line Input #Ff, a: Line Input #Ff, a: b = Split(a, ";"): Ag = b(0)              'n° dernier tirage (aaaannn) pr future actualisation
            Close #Ff
        End If
        Ff = FreeFile
        Open Ch For Input As #Ff
            Line Input #Ff, a                                                                   'ignorer ligne de titre
            Do While Not EOF(Ff)
                Line Input #Ff, a
                If a <> "" Then                                                                 'ignorer éventuels CRLF parasites
                    b = Split(a, ";")
                    For i = 1 To UBound(Ta)
                        For j = 1 To 4
                            Tb(j) = b(Ta(i, j) + 3)                                             'sources: liste n° commence col 5
                        Next j
                        j = CmbRk(Tb, 70, 4)                                                    'rang du quarté à incrémenter
                        Tc(j) = Tc(j) + 1                                                       'incrémentation
                    Next i
                    n = n + 1                                                                   'compteur
                    Application.StatusBar = "Nb de tirages analysés : " & n
                    DoEvents
                End If
            Loop
        Close #Ff
    Next k
    Erase Ta: Erase Tb: Erase b
    Sheets.Add
    Application.StatusBar = "Affichage..."
    Application.ScreenUpdating = False
    Cells(1, 3) = n & " tirages"
    Cells(2, 3) = "numéro du dernier tirages : " & Ag
    For i = 1 To UBound(Tc): Cells(i, 1) = Tc(i): Next i
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "Ready"
End Sub
Function CmbN(ByVal a&, ByVal b&) As Long()                         'combinaisons(a,b)
    Dim n&, Tb&(), c&, i&, j&
    n = CmbNb(a, b): ReDim Tb(1 To n, 1 To b): c = a - b
    For i = 1 To b: Tb(1, i) = i: Next i
    For i = 2 To n
        If b = 1 Then Tb(i, 1) = Tb(i - 1, 1) + 1 Else Tb(i, 1) = Tb(i - 1, 1) - (Tb(i - 1, 2) = c + 2)
        For j = 2 To b - 1
            If Tb(i - 1, j + 1) = c + j + 1 Then
                If Tb(i - 1, j) = c + j Then Tb(i, j) = Tb(i, j - 1) + 1 Else Tb(i, j) = Tb(i - 1, j) + 1
            Else
                Tb(i, j) = Tb(i - 1, j)
            End If
        Next j
        If Tb(i - 1, b) = a Then Tb(i, b) = Tb(i, b - 1) + 1 Else Tb(i, b) = Tb(i - 1, b) + 1
    Next i
    CmbN = Tb
End Function
Function CmbNb(ByVal a&, ByVal b&) As Long                          'nb combinaisons(a,b)
    Dim c&
    c = a - b
    If c = 0 Then
        CmbNb = 1
    Else
        If b < c Then c = b
        CmbNb = FacL(a, c) / FacL(c)
    End If
End Function
Function FacL(ByVal a&, Optional b) As Long                         'factorielle (option nb itérations)
    Dim i&, c&
    If Not IsMissing(b) Then c = CLng(b) Else c = a
    If a = 0 Or c = 0 Then FacL = 1: Exit Function
    FacL = a
    For i = 2 To c: FacL = FacL * (a - i + 1): Next i
End Function
Sub LfToCrlf(Ch$)                                                   'fichier Lf en fichier CrLf
    Dim a$, Ff%
    Ff = FreeFile
    Open Ch For Input As #Ff
    a = Replace$(Replace$(Input(LOF(1), #Ff), vbCrLf, vbLf), vbLf, vbCrLf)
    Close #Ff
    Kill Ch
    Ff = FreeFile
    Open Ch For Output As #Ff
    Print #Ff, a
    Close #Ff
End Sub
Function CmbRk(Cb&(), a&, b&) As Long                              'rang de la combinaison Cb (cb(0)=0) dans combinaisons(a,b)
    Dim i&, j&
    For j = 1 To UBound(Cb): For i = Cb(j - 1) + 2 To Cb(j): CmbRk = CmbRk + CmbNb(a + 1 - i, b - j): Next i, j
    CmbRk = CmbRk + 1
End Function
Function NCmb(ByVal a&, ByVal b&, ByVal c&) As Long()               'c ième combinaison(a,b)
    Dim Tb&(), i&, bS As Boolean, x&, d&
    ReDim Tb(0 To b)
    Do
        d = d + 1: x = 0: bS = False
        For i = a - 1 - Tb(d - 1) To b - d Step -1
            x = x + CmbNb(i, b - d)
            If c <= x Then bS = True: Exit For
        Next i
        Tb(d) = a - i: c = c - x + CmbNb(i, b - d)
    Loop Until d = b
    NCmb = Tb
End Function
Function NCmbTxt(ByVal a&, ByVal b&, ByVal c&) As String            'c ième combinaison(a,b), mode texte
    Dim d&(), i&
    d = NCmb(a, b, c): NCmbTxt = d(1)
    For i = 2 To UBound(d): NCmbTxt = NCmbTxt & "," & d(i): Next i
End Function
Sub Jad73QActua()
    Dim Ff%, Ch$, a$, b$(), Ta&(), Tb&(), i&, j&, Tc&(1 To 916895), n&, Dt$, c&, d&, e&, Ag$
    If MsgBox("Cette sub actualise les résultats de la feuille active", 1) = 2 Then Exit Sub
    Do
        Dt = Application.InputBox(prompt:="n° du dernier tirage pris en compte ?", Title:="format aaaannn", Type:=2): c = Val(Dt)
        If c = 0 Then Exit Sub
    Loop Until Len(CStr(c)) = 7
    Application.Calculation = xlCalculationManual
    c = CLng(Left(Dt, 4)): d = CLng(Right(Dt, 3)): Ch = ThisWorkbook.Path & "\keno_gagnant_a_vie.csv": LfToCrlf (Ch): Ff = FreeFile
    Open Ch For Input As #Ff
        Line Input #Ff, a: Line Input #Ff, a: b = Split(a, ";"): Ag = b(0)
    Close #Ff
    Ta = CmbN(20, 4): ReDim Tb(4): Ff = FreeFile
    Open Ch For Input As #Ff
        Line Input #Ff, a
        Do While Not EOF(Ff)
            Line Input #Ff, a
            If a <> "" Then
                b = Split(a, ";"): e = CLng(Left(b(0), 4))
                If e < c Or (e = c And Not (CLng(Right(b(0), 3)) > d)) Then Exit Do
                For i = 1 To UBound(Ta): For j = 1 To 4
                        Tb(j) = b(Ta(i, j) + 3)
                    Next j
                    j = CmbRk(Tb, 70, 4): Tc(j) = Tc(j) + 1
                Next i
                n = n + 1: Application.StatusBar = "Nb de tirages analysés : " & n: DoEvents
            End If
        Loop
    Close #Ff
    Erase Ta: Erase Tb: Erase b
    If n > 0 Then
        Application.StatusBar = "Actualisation de l'affichage..."
        Application.ScreenUpdating = False
        Cells(1, 3) = n & " tirages ajoutés": Cells(2, 3) = "numéro du dernier tirage : " & Ag
        For i = 1 To UBound(Tc)
            If Tc(i) > 0 Then Cells(i, 1) = Cells(i, 1) + Tc(i)
        Next i
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        Cells(3, 3) = "nombre de tirages total : " & (WorksheetFunction.Sum(Range(Cells(1, 1), Cells(916895, 1))) / WorksheetFunction.Combin(20, 4))
        Application.Calculation = xlCalculationManual
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "Ready"
End Sub

 

[jad73]

Re : anlyse trés longue

bonjour kendev, le forum
j'ai donc fait un dossier quartés avec la feuille de calcul contenant votre code, la macro et j'ai téléchargé les 2 fichiers de la fdj.
je clique sur la macro je rentre le n° du dernier tirage(2013608),OK et la j'ai un message d'erreur d'exécution'53' fichier introuvable.
Les 2 fichiers de la fdj faut-il les dezipper, les ajouter l'un après l'autre.
merci

 

[KenDev]

Re : anlyse trés longue

Bonjour à tous,

@jad73,

Oui les deux fichiers doivent être dézippés (d'ou l'extension .csv indiquée et non .zip). Vous avez lancé Jad73QActua, la macro actualisation alors que pour la première utilisation il vous faut lancer Jad73Q, celle ci ne vous demandera rien. Pour les utilisationss suivantes revenez à Jad73QActua.

Une bonne nouvelle, le fichier ne pèse que 7,5 Mo finalement...

Cordialement

KD

 

[jad73]

Re : anlyse trés longue

bonjour kendev, le forum
encore merci pour cet excellent code, effectivement je passe de 5h avec la formule pour tous les quartés a 5 à 6 minutes
c'est sans commentaire.
merci