Ferbank
XLDnaute Occasionnel
Bonjour voici un fichier Excel d'où on extrait des stats de 3 ou 4 nombres sortis depuis un listing de tirages, bien.
Comment modifier cette même macro pour extraire que 2 nombres du même listing avec les mêmes critères?
J'ai affiché le listing est il possible de le modifier depuis ce listing et le recoller dans le fichier?
Merci de vos possibilités de recherches.
Ferbank
Sub Triplets()
'---------------------------------------------------------------------------
' Rechercher des triplets parmi un tableau de tirages.
' Chaque tirage est en ligne.
' Chaque tirage comporte 5 nombres (compris entre 1 et 49) sans doublons
' 1) On lit le tableau initial et on trie chaque tirage
' tableau sur feuille active, une ligne d'en-tête,
' 1ère colonne =date, 2ième col. = Numéro tirage,
' colonnes suivantes = tirage
' Une colonne vide à droite du tableau
' Une ligne vide sous le tableau
' 2) Pour chaque ligne du tableau trié, on recherche tous les triplets.
' pour chaque triplet trouvé, on stocke dans un tableau
' à la ligne correspondant au triplet, le numéro du tirage.
' ce tableau.
'
' 3) On affiche le résultat
'---------------------------------------------------------------------------
'---- Déclarations
Dim Nb& ' Nombre max de triplets
Dim Triplet$() ' Les triplets résultats
Dim TotLigne() ' Nb triplets + N° tirage
Dim i&, j&, k&, l&, m&
Dim T$ ' Triplet à rechercher
Dim ici& ' Ligne de triplet correspondant à T
Dim Vals ' Tableau initial
Dim DerLig& ' Nombre de lignes à prendre en compte
Dim DerCol& ' Nombre de colonnes du tableau
Dim Vtmp() ' Tableau temporaire pour trier les tirages
Dim T0#, T1#, T2#, T3# ' Stockage des temps et de la durée totale
Dim xrg As Range ' Range du tableau initial
Nb = 50# * 49 * 48 / 6 ' Nombre max de triplets
ReDim Triplet(1 To Nb) ' Liste des triplets
ReDim TotLigne(1 To Nb, 1 To 2) ' Nombre de tirages pour chaque triplet
' et numéros tirage du triplet
Dim NbCol As Long ' Nombre de dates d'un triplet
Dim NbColMax As Long ' Nombre maximal de dates trouvées pour l'ensemble des triplets
'---- Environnement
Columns("I:XFD").Delete Shift:=xlToLeft
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
T0 = Timer
'---- RàZ & acquisition du tableau des tirages
Set xrg = Range("A1").CurrentRegion
Set xrg = xrg.Offset(1, 1).Resize(xrg.Rows.Count - 1, xrg.Columns.Count - 1)
' Lecture tirage
DerLig = 0
' DerLig = Application.InputBox(prompt:="Nombre de tirage à prendre en compte ( 0=tout) ?", Default:=0, Type:=1)
If DerLig = 0 Then DerLig = xrg.Rows.Count
' If DerLig > xrg.Rows.Count Then DerLig = xrg.Rows.Count
' Set xrg = xrg.Resize(DerLig)
Vals = xrg.Value
DerCol = xrg.Columns.Count
'---- Tri des lignes du tableau
ReDim Vtmp(1 To DerCol - 1) 'Tableau tempo
' Boucle sur chaque ligne du tirage pour remplir V pour le tri
For i = 1 To DerLig
' Boucle sur les colonnes du tirage
For j = 2 To DerCol
Vtmp(j - 1) = Vals(i, j)
Next j
' Tri de V
Qsort Vtmp, 1, DerCol - 1
' On remplace les valeurs non triées par les valeurs triées
For j = 2 To DerCol
Vals(i, j) = Vtmp(j - 1)
Next j
Next i
' Écriture du tableau trié sur la feuille
xrg.Value = Vals
'---- remplissage du tableau des triplets
For i = 1 To 48
For j = i + 1 To 49
For k = j + 1 To 50
m = m + 1
Triplet(m) = Format(i, "00") & Format(j, "00") & Format(k, "00")
Next k
Next j
Next i
T1 = Timer - T0
T0 = Timer
'---- Boucle comptage
' Pour chaque ligne du tableau
For i = 1 To DerLig
' Pour chaque triplet de la ligne
For j = 2 To DerCol - 2
For k = j + 1 To DerCol - 1
For m = k + 1 To DerCol
T = Format(Vals(i, j), "00") & Format(Vals(i, k), "00") & Format(Vals(i, m), "00")
' Recherche du triplet t dans triplet()
ici = Recherche_Dichotomique(Triplet, T)
TotLigne(ici, 1) = TotLigne(ici, 1) + 1
TotLigne(ici, 2) = TotLigne(ici, 2) & " " & 1 * Cells(i, 1).Offset(1, 0)
Next m
Next k
Next j
Next i
T2 = Timer - T0
T0 = Timer
'---- Écriture
ReDim Vals(1 To Nb, 1 To 3)
NbColMax = 0
For i = 1 To Nb
Vals(i, 1) = Left(Triplet(i), 2)
Vals(i, 2) = Mid(Triplet(i), 3, 2)
Vals(i, 3) = Right(Triplet(i), 2)
TotLigne(i, 2) = Trim(TotLigne(i, 2))
NbCol = Len(TotLigne(i, 2)) - Len(Replace(TotLigne(i, 2), " ", "")) + 1
If NbCol > NbColMax Then NbColMax = NbCol
Next i
xrg.Offset(, xrg.Columns.Count + 1).Resize(Nb, 3) = Vals
xrg.Offset(, xrg.Columns.Count + 4).Resize(Nb, 2) = TotLigne
Columns("M:M").TextToColumns _
Destination:=Range("M1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=True, _
Other:=False, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'---- Mise en forme
Range("I1:L1") = Array("N° 1", "N° 2", "N° 3", "Sorties")
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 9), Cells(Nb + 1, NbColMax + 12)), , xlYes).Name = "t_Resultats"
ActiveSheet.ListObjects("t_Resultats").TableStyle = "Style de tableau 1"
Range("t_Resultats[#All]").HorizontalAlignment = xlCenter
Range("t_Resultats[#Headers]").Interior.Color = RGB(255, 255, 153)
Range("t_Resultats[#Headers]").HorizontalAlignment = xlLeft
Range("t_Resultats[#Headers]").IndentLevel = 1
Range("t_Resultats[#Headers]").Font.Bold = True
Range("t_Resultats").Interior.Color = RGB(255, 255, 204)
Range("t_Resultats[[#Headers],[N° 1]:[N° 3]]").Interior.Color = RGB(189, 215, 238)
Range("t_Resultats[[#Headers],[N° 1]:[N° 3]]").IndentLevel = 0
Range("t_Resultats[[N° 1]:[N° 3]]").Interior.Color = RGB(221, 235, 247)
Range("t_Resultats[[N° 1]:[N° 3]]").NumberFormat = "00"
Range("t_Resultats[[N° 1]:[N° 3]]").ColumnWidth = 6.5
Range("t_Resultats[[#Headers],[Sorties]]").Interior.Color = RGB(204, 153, 255)
Range("t_Resultats[[#Headers],[Sorties]]").IndentLevel = 0
Range("t_Resultats[Sorties]").Interior.Color = RGB(255, 205, 255)
Range("t_Resultats[Sorties]").NumberFormat = "General"
Range("t_Resultats[Sorties]").ColumnWidth = 7.5
With Range(Cells(2, 13), Cells(1 + Nb, 12 + NbColMax))
.Font.Name = "Courier New"
.Font.Size = 9
.ColumnWidth = 12
.NumberFormat = "dd/mm/yyyy;@"
End With
Range("Tableau1[[#Headers],[Date]]").Select
T3 = Timer - T0
'---- Restaurer Environnement
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MonTexte = "Initialisations" & String(26, ".") & " : " & Format(T1, "0.00") & " sec." & vbCrLf
MonTexte = MonTexte & "Comptabilisation des triplets : " & Format(T2, "0.00") & " sec." & vbCrLf
MonTexte = MonTexte & "Écriture des résultats" & String(14, ".") & " : " & Format(T3, "0.00") & " sec." & vbCrLf & vbCrLf
MonTexte = MonTexte & "Durée totale : " & Format(T1 + T2 + T3, "0.00") & " sec."
MsgBox MonTexte
End Sub
Comment modifier cette même macro pour extraire que 2 nombres du même listing avec les mêmes critères?
J'ai affiché le listing est il possible de le modifier depuis ce listing et le recoller dans le fichier?
Merci de vos possibilités de recherches.
Ferbank
Sub Triplets()
'---------------------------------------------------------------------------
' Rechercher des triplets parmi un tableau de tirages.
' Chaque tirage est en ligne.
' Chaque tirage comporte 5 nombres (compris entre 1 et 49) sans doublons
' 1) On lit le tableau initial et on trie chaque tirage
' tableau sur feuille active, une ligne d'en-tête,
' 1ère colonne =date, 2ième col. = Numéro tirage,
' colonnes suivantes = tirage
' Une colonne vide à droite du tableau
' Une ligne vide sous le tableau
' 2) Pour chaque ligne du tableau trié, on recherche tous les triplets.
' pour chaque triplet trouvé, on stocke dans un tableau
' à la ligne correspondant au triplet, le numéro du tirage.
' ce tableau.
'
' 3) On affiche le résultat
'---------------------------------------------------------------------------
'---- Déclarations
Dim Nb& ' Nombre max de triplets
Dim Triplet$() ' Les triplets résultats
Dim TotLigne() ' Nb triplets + N° tirage
Dim i&, j&, k&, l&, m&
Dim T$ ' Triplet à rechercher
Dim ici& ' Ligne de triplet correspondant à T
Dim Vals ' Tableau initial
Dim DerLig& ' Nombre de lignes à prendre en compte
Dim DerCol& ' Nombre de colonnes du tableau
Dim Vtmp() ' Tableau temporaire pour trier les tirages
Dim T0#, T1#, T2#, T3# ' Stockage des temps et de la durée totale
Dim xrg As Range ' Range du tableau initial
Nb = 50# * 49 * 48 / 6 ' Nombre max de triplets
ReDim Triplet(1 To Nb) ' Liste des triplets
ReDim TotLigne(1 To Nb, 1 To 2) ' Nombre de tirages pour chaque triplet
' et numéros tirage du triplet
Dim NbCol As Long ' Nombre de dates d'un triplet
Dim NbColMax As Long ' Nombre maximal de dates trouvées pour l'ensemble des triplets
'---- Environnement
Columns("I:XFD").Delete Shift:=xlToLeft
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
T0 = Timer
'---- RàZ & acquisition du tableau des tirages
Set xrg = Range("A1").CurrentRegion
Set xrg = xrg.Offset(1, 1).Resize(xrg.Rows.Count - 1, xrg.Columns.Count - 1)
' Lecture tirage
DerLig = 0
' DerLig = Application.InputBox(prompt:="Nombre de tirage à prendre en compte ( 0=tout) ?", Default:=0, Type:=1)
If DerLig = 0 Then DerLig = xrg.Rows.Count
' If DerLig > xrg.Rows.Count Then DerLig = xrg.Rows.Count
' Set xrg = xrg.Resize(DerLig)
Vals = xrg.Value
DerCol = xrg.Columns.Count
'---- Tri des lignes du tableau
ReDim Vtmp(1 To DerCol - 1) 'Tableau tempo
' Boucle sur chaque ligne du tirage pour remplir V pour le tri
For i = 1 To DerLig
' Boucle sur les colonnes du tirage
For j = 2 To DerCol
Vtmp(j - 1) = Vals(i, j)
Next j
' Tri de V
Qsort Vtmp, 1, DerCol - 1
' On remplace les valeurs non triées par les valeurs triées
For j = 2 To DerCol
Vals(i, j) = Vtmp(j - 1)
Next j
Next i
' Écriture du tableau trié sur la feuille
xrg.Value = Vals
'---- remplissage du tableau des triplets
For i = 1 To 48
For j = i + 1 To 49
For k = j + 1 To 50
m = m + 1
Triplet(m) = Format(i, "00") & Format(j, "00") & Format(k, "00")
Next k
Next j
Next i
T1 = Timer - T0
T0 = Timer
'---- Boucle comptage
' Pour chaque ligne du tableau
For i = 1 To DerLig
' Pour chaque triplet de la ligne
For j = 2 To DerCol - 2
For k = j + 1 To DerCol - 1
For m = k + 1 To DerCol
T = Format(Vals(i, j), "00") & Format(Vals(i, k), "00") & Format(Vals(i, m), "00")
' Recherche du triplet t dans triplet()
ici = Recherche_Dichotomique(Triplet, T)
TotLigne(ici, 1) = TotLigne(ici, 1) + 1
TotLigne(ici, 2) = TotLigne(ici, 2) & " " & 1 * Cells(i, 1).Offset(1, 0)
Next m
Next k
Next j
Next i
T2 = Timer - T0
T0 = Timer
'---- Écriture
ReDim Vals(1 To Nb, 1 To 3)
NbColMax = 0
For i = 1 To Nb
Vals(i, 1) = Left(Triplet(i), 2)
Vals(i, 2) = Mid(Triplet(i), 3, 2)
Vals(i, 3) = Right(Triplet(i), 2)
TotLigne(i, 2) = Trim(TotLigne(i, 2))
NbCol = Len(TotLigne(i, 2)) - Len(Replace(TotLigne(i, 2), " ", "")) + 1
If NbCol > NbColMax Then NbColMax = NbCol
Next i
xrg.Offset(, xrg.Columns.Count + 1).Resize(Nb, 3) = Vals
xrg.Offset(, xrg.Columns.Count + 4).Resize(Nb, 2) = TotLigne
Columns("M:M").TextToColumns _
Destination:=Range("M1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, _
Tab:=True, _
Semicolon:=False, _
Comma:=False, _
Space:=True, _
Other:=False, _
FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'---- Mise en forme
Range("I1:L1") = Array("N° 1", "N° 2", "N° 3", "Sorties")
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 9), Cells(Nb + 1, NbColMax + 12)), , xlYes).Name = "t_Resultats"
ActiveSheet.ListObjects("t_Resultats").TableStyle = "Style de tableau 1"
Range("t_Resultats[#All]").HorizontalAlignment = xlCenter
Range("t_Resultats[#Headers]").Interior.Color = RGB(255, 255, 153)
Range("t_Resultats[#Headers]").HorizontalAlignment = xlLeft
Range("t_Resultats[#Headers]").IndentLevel = 1
Range("t_Resultats[#Headers]").Font.Bold = True
Range("t_Resultats").Interior.Color = RGB(255, 255, 204)
Range("t_Resultats[[#Headers],[N° 1]:[N° 3]]").Interior.Color = RGB(189, 215, 238)
Range("t_Resultats[[#Headers],[N° 1]:[N° 3]]").IndentLevel = 0
Range("t_Resultats[[N° 1]:[N° 3]]").Interior.Color = RGB(221, 235, 247)
Range("t_Resultats[[N° 1]:[N° 3]]").NumberFormat = "00"
Range("t_Resultats[[N° 1]:[N° 3]]").ColumnWidth = 6.5
Range("t_Resultats[[#Headers],[Sorties]]").Interior.Color = RGB(204, 153, 255)
Range("t_Resultats[[#Headers],[Sorties]]").IndentLevel = 0
Range("t_Resultats[Sorties]").Interior.Color = RGB(255, 205, 255)
Range("t_Resultats[Sorties]").NumberFormat = "General"
Range("t_Resultats[Sorties]").ColumnWidth = 7.5
With Range(Cells(2, 13), Cells(1 + Nb, 12 + NbColMax))
.Font.Name = "Courier New"
.Font.Size = 9
.ColumnWidth = 12
.NumberFormat = "dd/mm/yyyy;@"
End With
Range("Tableau1[[#Headers],[Date]]").Select
T3 = Timer - T0
'---- Restaurer Environnement
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
MonTexte = "Initialisations" & String(26, ".") & " : " & Format(T1, "0.00") & " sec." & vbCrLf
MonTexte = MonTexte & "Comptabilisation des triplets : " & Format(T2, "0.00") & " sec." & vbCrLf
MonTexte = MonTexte & "Écriture des résultats" & String(14, ".") & " : " & Format(T3, "0.00") & " sec." & vbCrLf & vbCrLf
MonTexte = MonTexte & "Durée totale : " & Format(T1 + T2 + T3, "0.00") & " sec."
MsgBox MonTexte
End Sub
on peut faire de bons pronostics y a pas de raison pour que les séries ne sortent pas au prochain tirage...
