XL 2019 formule simple

Ferbank · 30 Novembre 2022

Bonjour; comment formuler une syntaxe du genre rechercher par cellule une serie de 2 n° sortis le plus frequemment , dans une colones definie et contenant tous les tirages du loto ou euromillon. dans une autre une colonne avec date.

Pour compliquer avec 3n° .

Par exemple les n° 41
Merci pour vos idées

job75 · 1 Décembre 2022

Bonjour Ferbank, le forum,

Ferbank à dit:
Bonjour; comment formuler une syntaxe du genre rechercher par cellule une serie de 2 n° sortis le plus frequemment ,

Voyez si le fichier joint et ces 2 macros correspondent à ce que vous voulez :

VB:

Sub Frequence_max_2_numeros()
Dim dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, x$, maxi&, a, b, resu$(), n&
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 1
        If s(j) <> "" Then
            For k = j + 1 To ub
                If s(k) <> "" Then
                    x = s(j) & "-" & s(k)
                    d(x) = d(x) + 1 'comptage
                    dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 2 numéros : " & maxi
End Sub

Sub Frequence_max_3_numeros()
Dim dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, m%, x$, maxi&, a, b, resu$(), n&
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 2
        If s(j) <> "" Then
            For k = j + 1 To ub - 1
                If s(k) <> "" Then
                    For m = k + 1 To ub
                        If s(m) <> "" Then
                            x = s(j) & "-" & s(k) & "-" & s(m)
                            d(x) = d(x) + 1 'comptage
                            dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                        End If
                    Next m
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 3 numéros : " & maxi
End Sub

Ces macros sont très rapides car elles utilisent des tableaux VBA et 2 Dictionary.

A+

job75 · 1 Décembre 2022

Ferbank à dit:
Par exemple les n° 41

Je me suis demandé ce que vous vouliez dire, en fait c'est un numéro cible, voyez ce fichier (2) :

VB:

Sub Frequence_max_2_numeros()
Dim numcible$, dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, x$, y$, maxi&, a, b, resu$(), n&
numcible = "*-" & IIf([J11] = "", "*", [J11]) & "-*" 'n° cible encadré + caractère générique *
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 1
        If s(j) <> "" Then
            For k = j + 1 To ub
                If s(k) <> "" Then
                    x = s(j) & "-" & s(k)
                    y = "-" & x & "-" 'texte encadré
                    If y Like numcible Then
                        d(x) = d(x) + 1 'comptage
                        dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                    End If
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 2 numéros : " & maxi
End Sub

Sub Frequence_max_3_numeros()
Dim numcible$, dest As Range, d As Object, dd As Object, tablo, i&, s, ub%, j%, k%, m%, x$, y$, maxi&, a, b, resu$(), n&
numcible = "*-" & IIf([J11] = "", "*", [J11]) & "-*"  'n° cible encadré + caractère générique *
Set dest = [F14] '1ère cellule de destination, à adapter
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
tablo = [B14].CurrentRegion.Resize(, 3) 'matrice, plus rapide
For i = 1 To UBound(tablo)
    s = Split(tablo(i, 3), "-")
    ub = UBound(s)
    For j = 0 To ub - 2
        If s(j) <> "" Then
            For k = j + 1 To ub - 1
                If s(k) <> "" Then
                    For m = k + 1 To ub
                        If s(m) <> "" Then
                            x = s(j) & "-" & s(k) & "-" & s(m)
                            y = "-" & x & "-" 'texte encadré
                            If y Like numcible Then
                                d(x) = d(x) + 1 'comptage
                                dd(x) = dd(x) & "-" & tablo(i, 1) 'dates
                            End If
                        End If
                    Next m
                End If
            Next k
        End If
Next j, i
'---restitution---
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
If d.Count Then
    maxi = Application.Max(d.items)
    a = d.keys
    b = dd.items
    ReDim resu(1 To UBound(a) + 1, 1 To 2)
    For i = 0 To UBound(a)
        If d(a(i)) = maxi Then
            n = n + 1
            resu(n, 1) = a(i)
            resu(n, 2) = Mid(b(i), 2)
        End If
    Next i
    dest.Resize(n, 2) = resu
End If
dest.Offset(n).Resize(Rows.Count - n - dest.Row + 1, 2).ClearContents 'RAZ en dessous
dest(0) = "Fréquence max 3 numéros : " & maxi
End Sub

Quand J11 est vide on se retrouve dans le cas du fichier (1) du post #2.

Ferbank · 1 Décembre 2022

Bonjour et grand merci pour votre aide, en fait je voulais connaitre les séries les plus sorties;
Serie à 2 ou 3 ou 4 n°
je joins le tableau modifié pour l'année 2022.
j'utilise en référence votre tableau que j'ai emménagé avec différentes formules de recherche pour les stats.

Ferbank · 1 Décembre 2022

RE je vous joins le tableau que j'utilise pour mes stats n'hésitez pas à me demander le but des recherches.
C'est vous qui me l'avez conçu je l'ai simplement emménagé à mes besoins.
Quand j'incrémente un résultât dans les colonnes Cà K: les tirages recopiés dans les feuilles de STAT Triplets le pc met un certain temps à recalculer pourquoi?
Voilà mon tableau et j'en suis fortement reconnaissant de me l'avoir conçu en VB.

LOTO_FERBANK.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

job75 · 1 Décembre 2022

Le fichier du post #4 en retour avec la 3ème macro et le 3ème bouton.

natorp · 1 Décembre 2022

Bjr le fil

JOB75 : Je me permets de m'immiscer : lorsque l'on clique sur le 3ème bouton, on obtient une liste de 2 séries de 3 numéros avec des doublons de dates.

Merci, cordialement, Gérard

job75 · 1 Décembre 2022

Bonjour natorp et merci d'avoir testé.

Effectivement dans la 3ème macro j'avais oublié de concaténer s(p), j'ai corrigé le fichier du post #6.

A+

natorp · 1 Décembre 2022

job75 à dit:
Bonjour natorp et merci d'avoir testé.

Effectivement dans la 3ème macro j'avais oublié de concaténer s(p), j'ai corrigé le fichier du post #6.

A+

Super !! Merci
Cordialement, Gérard

job75 · 1 Décembre 2022

Concernant le post #5 et votre fichier :

Ferbank à dit:
Quand j'incrémente un résultât dans les colonnes Cà K: les tirages recopiés dans les feuilles de STAT Triplets le pc met un certain temps à recalculer pourquoi?

Parce qu'il y a des formules qui se recalculent dans la feuille mais c'est quand même assez rapide.

Par contre la macro Workshet_Change dans la 1ère feuille prend trop de temps.

Quand je modifie la cellule T11 l'exécution se fait chez moi en 8,6 secondes.

Pour y remédier il faut passer en calcul manuel avec les Application.Calculation, donc utilisez :

VB:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Recherche As Range, NC As Range, P As Range, Dates As Range, Complement As Range, R As Range, c As Range, Q As Range
Set Recherche = [T11:X11]
Set NC = [Y11] 'recherche du numéro complémentaire
Set P = [E:I]
Set Dates = [D:D]
Set Complement = [J:J]
If Intersect(Target, Union(Recherche, NC)) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'mode de calcul manuel
On Error Resume Next 'si aucune SpecialCell
'Recherche.Offset(1).Resize(Rows.Count - Recherche.Row, Recherche.Columns.Count + 2).Delete xlUp 'RAZ
Recherche.Offset(1).Resize(Rows.Count - Recherche.Row, Recherche.Columns.Count + 2).ClearContents 'RAZ

If NC = "" Then
    Set R = P
Else
    Complement.Replace NC, "#N/A", xlWhole
    Set R = Complement.SpecialCells(xlCellTypeConstants, 16)
    If R Is Nothing Then GoTo 1
    R = NC
    Set R = Intersect(R.EntireRow, P)
End If
For Each c In Recherche
    If c <> "" Then
        P.Replace c, "#N/A", xlWhole
        Set Q = Nothing
        Set Q = P.SpecialCells(xlCellTypeConstants, 16)
        If Q Is Nothing Then GoTo 1
        Q = c
        Set Q = Intersect(Q.EntireRow, P)
        Set R = Intersect(Q, R)
    End If
Next
'---résultat---
R.Copy Recherche(2, 1)
Intersect(R.EntireRow, Complement).Copy NC(2)
Intersect(R.EntireRow, Dates).Copy NC(2, 2)
1 Application.Calculation = xlCalculationAutomatic 'rétablit le calcul automatique
End Sub

Maintenant l'exécution se fait chez moi en 1,2 seconde.

Effectuez une recherche sur Excel Downloads...

XL 2019 formule simple

Ferbank

XLDnaute Occasionnel

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Ferbank

XLDnaute Occasionnel

Pièces jointes

Ferbank

XLDnaute Occasionnel

LOTO_FERBANK.xlsm

job75

XLDnaute Barbatruc

Pièces jointes

natorp

XLDnaute Accro

job75

XLDnaute Barbatruc

natorp

XLDnaute Accro

job75

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums