Peut-on optimiser ce code VBA ?

B

Backhandshot

XLDnaute Occasionnel
Bonjour à tous!
J'aimerais savoir si vous seriez capable d'optimiser ce code VBA, c'est un fichier qui comporte des combinaisons de 2 chiffres de 1 à 70 (Keno 2415 combines). Environ 4-5 minutes pour faire le compte sur 7700 tirages aussi je voudrais que le numéro du tirage s'affiche dans les colonnes adjacentes. Je vous remercie pour votre aide.

Backhandshot
 

Pièces jointes

  • Classeur2.zip
    87 KB · Affichages: 112
  • Classeur2.zip
    87 KB · Affichages: 119
  • Classeur2.zip
    87 KB · Affichages: 142
Trier par date Trier par votes
G

Gelinotte

XLDnaute Accro
Re : Peut-on optimiser ce code VBA ?

Bonjour,

Désolé : J'ai fini par bien relire ton message et j'ai constaté que j'étais dans champ avec le temps, un accident 8- ))))


Mais pour l'ajout en Z du dernier tirage de la conbinaison, la ligne en verte que j'ai ajoutée.

Sub No()
Dim NB, NB1, Nbfois As Integer
Dim Rg As Range, i!, Lg!, Fin#
On Error GoTo Gest

Fin = [A65536].End(3).Row
Range("x1:y2500").ClearContents
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Lg = 1
For NB = 1 To 70
For NB1 = NB + 1 To 70
Set Rg = Range("c2:v2")
If [x2:x2500].Find(NB & "," & NB1, lookat:=xlWhole) Is Nothing And NB <> NB1 Then
Lg = Lg + 1
Cells(Lg, 24) = NB & "," & NB1
For i = 0 To Fin
If Rg.Offset(i, 0).Find(NB, lookat:=xlWhole) Is Nothing Or Rg.Offset(i, 0).Find(NB1, lookat:=xlWhole) Is Nothing Then
Nbfois = Nbfois + 1
Else
Cells(Lg, 25) = Cells(Lg, 25) + 1
Cells(Lg, 26) = i + 1
Nbfois = 0
End If
Next i
End If
Next NB1
Next NB
Gest:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox ("Terminé")
End Sub

G
 
Vote positif 0 Vote négatif
G

Gelinotte

XLDnaute Accro
Re : Peut-on optimiser ce code VBA ?

Bonjour,

En attendant, j'ai testé en désactivant une vérification. Je n'ai pas trouvé de différence. Donc ces lignes semblent inutiles (en rouge )

Sub No()
Dim NB, NB1, Nbfois As Integer
Dim Rg As Range, i!, Lg!, Fin#
On Error GoTo Gest

Fin = [A65536].End(3).Row
Range("x1:y2500").ClearContents
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Lg = 1
For NB = 1 To 70
For NB1 = NB + 1 To 70
Set Rg = Range("c2:v2")
'If [x2:x2500].Find(NB & "," & NB1, lookat:=xlWhole) Is Nothing And NB <> NB1 Then
Lg = Lg + 1
Cells(Lg, 24) = NB & "," & NB1
For i = 0 To Fin
If Rg.Offset(i, 0).Find(NB, lookat:=xlWhole) Is Nothing Or Rg.Offset(i, 0).Find(NB1, lookat:=xlWhole) Is Nothing Then
Nbfois = Nbfois + 1
Else
Cells(Lg, 25) = Cells(Lg, 25) + 1
Cells(Lg, 26) = i + 1
Nbfois = 0
End If
Next i
'End If
Next NB1
Next NB
Gest:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox ("Terminé")
End Sub
 
Vote positif 0 Vote négatif
G

Gelinotte

XLDnaute Accro
Re : Peut-on optimiser ce code VBA ?

Bonjour,

Dans la colonne Z (en couleur) est le dernier tirage de la combinaison.
De AA ..... s'incrivent les numéros de tirage qui ont cette combinaison.
Si une combinaison est sortie 5 fois, AA, AB, AC, AD et AE contiendront les numéros de ces 5 tirages.

Pour la rapidité d'exécution, tu as une liaison avec C:\Banco\Annoncer-Annonceur.xlsm
Je ne sais quelle influence il peut avoir.

Aussi, la vérification d'une condition qui semble inutile que j'ai désactivée, va sûrement aider à la réduire un tantinet le temps d'exécution.

Autre chose, comme tu as mentionné qu'il y a 7700 tirages à traiter, il risque d'y avoir un nombre important d'occurrences d'une combinaison. J'ai donc dynamisé la plage à effacer au début du traitement. Je fais chercher le nombre maximum d'occurences pour l'inclure dans la plage à effacer.
NNombre = Application.WorksheetFunction.Max(Range("y2:y2500"))
Range(Cells(2, 24), Cells(2420, 24 + NNombre)).ClearContents

Au lieu d'une plage fixe : Range("x1:ay2500").ClearContents qui pourrait devenir trop petite


Espérant le tout conforme.

G
 

Pièces jointes

  • Copie de Classeur2.xlsm
    22.6 KB · Affichages: 117
  • Copie de Classeur2.xlsm
    22.6 KB · Affichages: 132
  • Copie de Classeur2.xlsm
    22.6 KB · Affichages: 127
Dernière édition:
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Peut-on optimiser ce code VBA ?

Bonjour Backhandshot & Gelinotte,

Je suis TRÈS étonné du 4-5 minutes annoncé au 1er post pour 7700 tirages... Je sais que mon netbook se traîne mais quand même ça me semble très peu...

Bref un code alternatif qui m'annonce pour les 30 lignes du test 8 secondes contre 24 secondes pour la dernière version proposée. En extrapolant pour 7700 tirages on obtiendrait 34 minutes contre 1h42.

Dans un module standard, à lancer lorsque la feuille active est celle contenant les tirages. Les résultats sont sur une nouvelle feuille.

VB: 
Option Explicit

Sub Test()
Dim w(1 To 2) As Worksheet, i%, Rg As Range, Nb&, Tb&(), j&, Rw&, T
    T = Now
    Application.ScreenUpdating = False
    Nb = WorksheetFunction.Combin(70, 2)
    Set w(1) = ActiveSheet
    Rw = w(1).Cells(Rows.Count, 3).End(xlUp).Row
    Sheets.Add
    Set w(2) = ActiveSheet
    For i = 1 To 2
        w(2).Cells(1, i) = i
    Next i
    w(2).Cells(2, 1).FormulaR1C1 = "=IF(R[-1]C[1]=70,R[-1]C+1,R[-1]C)"
    w(2).Cells(2, 2).FormulaR1C1 = "=IF(R[-1]C=70,RC[-1]+1,R[-1]C+1)"
    Set Rg = w(2).Range(w(2).Cells(2, 1), w(2).Cells(Nb, 2))
    w(2).Range(w(2).Cells(2, 1), w(2).Cells(2, 2)).AutoFill Destination:=Rg
    Rg.Copy: Rg.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ReDim Tb(1 To Nb)
    For i = 1 To Nb
        Tb(i) = 3
    Next i
    For i = Rw To 2 Step -1
        w(2).Cells(1, 3).FormulaR1C1 = "=COUNTIF(" & w(1).Name & "!R" & i & "C:R" & i & "C[19],RC[-2])+COUNTIF(" & w(1).Name & "!R" & i & "C:R" & i & "C[19],RC[-1])"
        Set Rg = w(2).Range(w(2).Cells(1, 3), w(2).Cells(Nb, 3))
        w(2).Cells(1, 3).AutoFill Destination:=Rg
        Rg.Copy: Rg.PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
        For j = 1 To Nb
            If w(2).Cells(j, 3) = 2 Then
                Tb(j) = Tb(j) + 1
                w(2).Cells(j, Tb(j)) = i - 1
            End If
        Next j
    Next i
    For i = 1 To Nb
        w(2).Cells(i, 3) = Tb(i) - 3
    Next i
    w(2).Rows(1).Insert Shift:=xlDown
    w(2).Cells(1, 1) = "n1": w(2).Cells(1, 2) = "n2": w(2).Cells(1, 3) = "qté"
    Application.ScreenUpdating = True
    With w(2).Cells
        .HorizontalAlignment = xlCenter
        .EntireColumn.AutoFit
    End With
    MsgBox (T - Now) * 86400
End Sub

Cordialement

KD
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Peut-on optimiser ce code VBA ?

Bonjour Backhandshot & Gelinotte & KenDev,

Je suis aussi étonné des temps annoncés mais j'ai sans doute un vieux machin comme machine.

J'ai écris un autre code qui me donne environ 85-95s comme durée pour 7000 tirages
(La feuille 1 procède au tirage - le comptage se fait sur la feuille "Trié" où chaque tirage est ordonné en ordre croissant)


Code: 
Option Explicit

Sub Binome()

Const Nb = (70 * 70 - 70) / 2
Dim i, j, k, l, m
Dim Vals, DerLig
Dim Bin1(Nb), Bin2(Nb), BinNbr(Nb), BinTirage(Nb)
Dim OK, T1

Sheets("Trié").Activate
Range("X:XFD").ClearContents

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
T1 = Timer
'lecture tirage
DerLig = 30
DerLig = Application.InputBox(prompt:="Nombre de tirage à prendre en compte ( 0=tout) ?", Default:=30, Type:=1)
If DerLig = 0 Then
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
Else
    DerLig = DerLig + 1
End If

Vals = Range("C2:V2").Resize(DerLig - 1)

'remplissage binome de numéros
For i = 1 To 70
    For j = i + 1 To 70
        m = m + 1
        Bin1(m) = i: Bin2(m) = j
    Next j
Next i

'boucle comptage
For m = 1 To Nb
    For i = 1 To DerLig - 1
        OK = 0
        'recherche du 1ier nombre
        For j = 1 To 20
            If Vals(i, j) = Bin1(m) Then Exit For
        Next j
        If j < 21 Then
            For k = j + 1 To 20
                If Vals(i, k) = Bin2(m) Then
                    BinNbr(m) = BinNbr(m) + 1
                    BinTirage(m) = i & " " & BinTirage(m)
                    Exit For
                End If
            Next k
        End If
    Next i
Next m
            
'écriture des résultats
Const ColBase = "X"
Dim NcolBase, TT
NcolBase = Range(ColBase & 1).Column

For m = 1 To Nb
    Cells(m + 1, NcolBase) = Bin1(m) & "," & Bin2(m)
    Cells(m + 1, NcolBase).Offset(, 1) = BinNbr(m)
    If BinNbr(m) >= 1 Then
        TT = Split(BinTirage(m))
        Cells(m + 1, NcolBase).Offset(, 2).Resize(, UBound(TT) - LBound(TT) + 1) = TT
    End If
Next m

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox Timer - T1
End Sub


Function UnTirage()
Dim TT(1 To 20), NN(70), n, aux, i

For i = 1 To 70: NN(i) = i: Next i

For i = 1 To 20
    n = Application.WorksheetFunction.RandBetween(i, 70)
    TT(i) = NN(n)
    aux = NN(i)
    NN(i) = NN(n)
    NN(n) = aux
Next i
UnTirage = TT

End Function

Sub NNN_tirage()
Dim i
Dim T1

T1 = Timer
Sheets("Feuil1").Activate
Range("C2:V7001").ClearContents
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 2 To 7001
Cells(i, 3).Resize(, 20) = UnTirage
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

MsgBox Timer - T1

End Sub
 

Pièces jointes

  • keno.zip
    220 KB · Affichages: 176
  • keno.zip
    220 KB · Affichages: 177
  • keno.zip
    220 KB · Affichages: 193
Vote positif 0 Vote négatif
B

Backhandshot

XLDnaute Occasionnel
Re : Peut-on optimiser ce code VBA ?

Bonsoir Gelinotte, KenDev et mapomme !
J'ai testé les 3 méthodes Gelinotte 21 minutes 50 sec, KenDev 6 minutes 07 secondes et mapomme 113 secondes la méthode est très rapide. Merci à vous 3.
@plus
 
Dernière édition:
Vote positif 0 Vote négatif
KenDev

KenDev

XLDnaute Impliqué
Re : Peut-on optimiser ce code VBA ?

Bonjour ç tous,,

mapomme à dit:
Je suis aussi étonné des temps annoncés mais j'ai sans doute un vieux machin comme machine.

J'ai écris un autre code qui me donne environ 85-95s comme durée pour 7000 tirages
Cliquez pour agrandir...

Ton vieux machin marche pas trop mal, sur le mien ton code met 350 s ;) A priori ton code est près de 6 * plus rapide que le mien (estimation: pas la patiente de tester le mien sur 7000 lignes !). Je retiens particulièrement à la première lecture la déclaration d'un tableau directement sur une plage.

Cordialement

KD
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : Peut-on optimiser ce code VBA ?

(re)Bonjour Backhandshot,

Que veux tu dire par les chiffres se mélangent ?

Si je procède à des tirages sur la "Feuil1", c'est uniquement parce que je n'ai pas 7000 tirages de KENO sous la main :(

Pour ton propre cas, il faut copier tes tirages sur la "Feuil1". Ces tirages seront ordonnés sur la feuille "Trié" puis il faut lancer la macro de la feuille "Trié". En effet la macro de comptage suppose que chaque tirage est ordonné en ordre croissant.

Si tes tirages sont sur la feuille "Feuil1 et si chaque tirage est ordonné en ordre croissant, tu peux adapter la macro Binome() en remplaçant la ligne:
Code: 
Sheets("Trié").Activate
par la ligne
Code: 
Sheets("Feuil1").Activate
et laisser tomber la sub NNN_tirage() et la fonction UnTirage() et la feuille "Trié".

Edit : pour KenDev : Tu m'as rassuré sur les capa de ma bécane. Vu les 1ières valeurs annoncées, j'avais pris peur.
 
Dernière édition:
Vote positif 0 Vote négatif
B

Backhandshot

XLDnaute Occasionnel
Re : Peut-on optimiser ce code VBA ?

Bonsoir à tous!
J'ai modifié mon message... la 1 ère fois j'ai copié tous les tirages sur la feuille 1 et exécuter la macro TIRAGE tous les numéros se sont mélangés ensuite je suis allé sur la feuille trié et j'ai exécuté la macro comptage. J'ai relu ton message et j'ai juste copié les tirages sur la feuille trié et exécuter la macro et ça marche nickel 113 secondes pour 7662 tirages
Merci pour votre aide...il me reste juste à apprendre le code
 
Vote positif 0 Vote négatif

Discussions similaires

Mathmath06
  • Question
XL 2016 Calcul écart de combinaison de 4 numéros Keno
2
Réponses
15
Affichages
739
Mathmath06
Mathmath06
so_sophie
  • Question
Microsoft 365 Optimiser macro beaucoup trop lente (30 minutes !)
Réponses
5
Affichages
491
vgendron
vgendron
D
  • Question
XL 2019 Aide à la compréhension d'un code VBA
Réponses
4
Affichages
716
Dudu2
Dudu2
Etevaldo Santos
  • Résolu(e)
XL 2019 Filtre dynamique (VBA) sur des colonnes avec le format número or date
Réponses
6
Affichages
2 K
CJA33
C
S
  • Question
XL 2010 VBA - macro avec 1 boucle qui alterne 1 action à conditions et 1 action sans conditions
2 3 4
Réponses
58
Affichages
6 K
Scorp0211
S
M
  • Question
XL 2013 Combinaisons complexes sous VBA
Réponses
10
Affichages
1 K
marcodeco
M
Spinzi
  • Question
XL 2016 VBA - Optimisation Code Array
Réponses
5
Affichages
1 K
Spinzi
Spinzi
D
  • Question
XL 2010 code VBA recherche DBB
2
Réponses
22
Affichages
2 K
frederio
frederio
B
  • Question
Besoin aide pour trinôme avec VBA
Réponses
11
Affichages
3 K
Backhandshot
B
N
  • Question
Optimisation macro vba
Réponses
0
Affichages
2 K
nauj
N

Membres actuellement en ligne

23 membres et 346 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 091
Membres
103 467
dernier inscrit
Pandiska