il me marque à chaque fois déclarations existante dans la portée en cours
Voici la macro ci-dessous
Voici la macro ci-dessous
VB:
' ********** Début de la macro en jaune **********
Sub CompterPairesKenoV2()
' ********** Texte en jaune **********
Dim wsTirage As Worksheet
Dim wsCouple As Worksheet
Dim tirages As Range
Dim i As Long, j As Long, k As Long
Dim ligneCouple As Long
Dim tirageLigne As Range
Dim nums() As Integer
Dim dictPairs As Object
Dim key As String
Dim numCount As Long
Dim num1 As Integer, num2 As Integer
Dim currentDrawNum As Long
Dim lastPairAppearance(1 To 70, 1 To 70) As Long
Dim lastAppearance(1 To 70) As Long
' Configurer les feuilles de calcul
Set wsTirage = ThisWorkbook.Worksheets("Tirages keno")
Set wsCouple = ThisWorkbook.Worksheets("Compilation3N")
Set tirages = wsTirage.Range("B3:U" & wsTirage.Cells(Rows.Count, "B").End(xlUp).Row)
' Initialiser le dictionnaire pour les paires
Set dictPairs = CreateObject("Scripting.Dictionary")
wsCouple.Cells.ClearContents
With wsCouple
.Range("F1").Value = "Numéro 1"
.Range("G1").Value = "Numéro 2"
.Range("H1").Value = "Nombre de sorties"
.Range("I1").Value = "Écart actuel"
.Range("J1").Value = "Écart max"
End With
ligneCouple = 2
' Boucle à travers chaque tirage
For currentDrawNum = 1 To tirages.Rows.Count
Set tirageLigne = tirages.Rows(currentDrawNum)
ReDim nums(1 To tirageLigne.Columns.Count)
numCount = 0
' Extrait les numéros du tirage actuel
For j = 1 To tirageLigne.Columns.Count
If IsNumeric(tirageLigne.Cells(1, j).Value) And CInt(tirageLigne.Cells(1, j).Value) >= 1 And CInt(tirageLigne.Cells(1, j).Value) <= 70 Then
numCount = numCount + 1
nums(numCount) = CInt(tirageLigne.Cells(1, j).Value)
End If
Next j
' Traite les paires dans le tirage actuel
If numCount > 1 Then
For j = 1 To numCount - 1
For k = j + 1 To numCount
num1 = nums(j)
num2 = nums(k)
key = num1 & "-" & num2
' Met à jour le compte pour la paire
If dictPairs.Exists(key) Then
dictPairs(key)(0) = dictPairs(key)(0) + 1 ' Nombre de sorties
Else
dictPairs.Add key, Array(1, 0, 0) ' Nombre de sorties, Dernière apparition, Écart max
End If
' Met à jour la dernière apparition
lastPairAppearance(num1, num2) = currentDrawNum
lastPairAppearance(num2, num1) = currentDrawNum ' Assurer la symétrie
Next k
Next j
End If
' Met à jour les dernières apparitions pour tous les numéros
For j = 1 To numCount
lastAppearance(nums(j)) = currentDrawNum
Next j
Next currentDrawNum
' Calculer l'écart actuel et max
For Each pairKey In dictPairs.Keys
Dim parts() As String
parts = Split(pairKey, "-")
num1 = CInt(parts(0))
num2 = CInt(parts(1))
Dim lastApp As Long
lastApp = lastPairAppearance(num1, num2)
' Écart actuel
If lastApp > 0 Then
dictPairs(pairKey)(1) = currentDrawNum - lastApp ' Écart actuel
Else
dictPairs(pairKey)(1) = 0 ' Jamais apparu ensemble
End If
' Écart max
Dim gap As Long
gap = currentDrawNum - lastApp - 1
If gap > dictPairs(pairKey)(2) Then
dictPairs(pairKey)(2) = gap ' Écart max
End If
Next pairKey
' Remplit la feuille "Compilation3N" avec les résultats
For Each pairKey In dictPairs.Keys
Dim parts() As String
parts = Split(pairKey, "-")
num1 = CInt(parts(0))
num2 = CInt(parts(1))
With wsCouple
.Cells(ligneCouple, 6).Value = num1
.Cells(ligneCouple, 7).Value = num2
.Cells(ligneCouple, 8).Value = dictPairs(pairKey)(0) ' Nombre de sorties
.Cells(ligneCouple, 9).Value = dictPairs(pairKey)(1) ' Écart actuel
.Cells(ligneCouple, 10).Value = dictPairs(pairKey)(2) ' Écart max
End With
ligneCouple = ligneCouple + 1
Next pairKey
' Tri par "Nombre de sorties" (décroissant)
If ligneCouple > 2 Then
With wsCouple.Sort
.SortFields.Clear
.SortFields.Add key:=.Range("H2:H" & ligneCouple - 1), SortOn:=xlSortOnValues, Order:=xlDescending
.SetRange .Range("F1:J" & ligneCouple - 1)
.Header = xlYes
.Apply
End With
End If
MsgBox "Analyse des paires terminée !", vbInformation
End Sub
' ********** Fin de la macro en jaune **********
Dernière modification par un modérateur:
