Recherche Famille Unique X fois et faire une Liste

Bonjour je m'en remet a votre expertises pour le sujet suivant

Onglet "Log" = Datas

Onglet "Résultats"=Restitutions

Pour une Population composé d'entité Choisi, je voudrai recupérer le nombre de fois que cela ce presente dans "Log"

Fichier "log" peux aller à plus de 65000 lignes

Merci de votre aide

Cordialement

Bonjour barachoie

Je verrai bien une solution à base de formules pour repérer les séquences

une piste ici, je détecte le début des différentes séquences

A tester sur une copie de tes données

Sub test()
    Columns(1).Insert
    With Range("b2", Range("b" & Rows.Count).End(xlUp)).Offset(, -1)
        .Formula = _
        "=if(and(c2=2,c3=4,c4=6,c5=8,c6=10,c7=12,c8=14,c9=16,c10=18,c11=20,c12=22,c13=24),1,"""")"
    End With
End Sub

Si les formulistes pouvaient m'aider dur ce coup là

klin89

Bonjour et Merci Klin89.

Pour info la série voulu type 2,4,6,8 etc... n'est pas fixe car on pourrait avoir 1,7,25 ou 1,5,10,12,17,23 bref une série voulu

mais ne suit pas une logique prédéfini.

Aidez moi svp car je cale sur le sujet

Merci d'avance

Re barachoie,

Feuille "resultats", cellule F1, j'ai placé cette formule :

=NBCAR(SUPPRESPACE(C1))-NBCAR(SUBSTITUE(SUPPRESPACE(C1);",";""))+1

Pour rechercher les séquences, je me suis appuyé sur la colonne SLOT et non WAFER

A tester, la restitution s'effectue en Feuil1 préalablement créée

C'est peut-être perfectible

Option Explicit
Sub test()
Dim r As Range, rng As Range, txt As String, identite As String
Dim nbreOcc As Byte, i As Byte, n As Long
    identite = Join$(Split(Sheets("resultats").Range("c1").Value, ","), "")
    nbreOcc = Sheets("resultats").Range("f1").Value
    Application.ScreenUpdating = False
    With Sheets("Logs")
        Set rng = .Range("b2", .Range("b" & Rows.Count).End(xlUp))
    End With
    n = 1
    For Each r In rng
        For i = 1 To nbreOcc
            txt = txt & r(i).Value
        Next
        If txt = identite Then
            r.Offset(, -1).Resize(nbreOcc, 12).Copy Sheets("Feuil1").Cells(n, 1)
            n = n + nbreOcc + 1
        End If
        txt = ""
    Next
    Set rng = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Merci

c'est Fabuleux, je m'empresse de le mettre sur une base complete

et je reviendrai vers toi pour un retour.

Merci infiniment tu es un génie

Re barachoie,

Sûrement plus rapide :

Option Explicit
Sub test()
Dim txt As String, identite As String, nbreOcc
Dim dLig As Long, lig As Long, n As Long, k As Byte
    identite = Join$(Split(Sheets("resultats").Range("c1").Value, ","), "")
    nbreOcc = Sheets("resultats").Range("f1").Value
    Application.ScreenUpdating = False
    Sheets("Feuil1").Cells.Clear
    With Sheets("Logs")
        lig = 2
        dLig = .Range("b" & Rows.Count).End(xlUp).Row
        Do While lig <= dLig - nbreOcc + 1
            For k = 1 To nbreOcc
                txt = txt & .Cells(lig + k - 1, 2).Value
            Next
            If txt = identite Then
                n = n + 1
                .Cells(lig, 1).Resize(nbreOcc, 12).Copy Sheets("Feuil1").Cells(n, 1)
                lig = lig + nbreOcc
                n = n + nbreOcc
            Else
                lig = lig + 1
            End If
            txt = ""
        Loop
        If n = 0 Then MsgBox "aucune séquence n'a été trouvée"
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Re,

Je savais bien que c'était perfectible

En C1, la saisie de l'une des 2 chaines suivantes 10,12,14 ou 101,21,4 renvoyait le même résultat

J'ai donc intégrer un délimiteur dans la chaine txt :

Option Explicit
Sub test()
Dim txt As String, identite As String, nbreOcc
Dim dLig As Long, lig As Long, n As Long, k As Byte
    identite = Sheets("resultats").Range("c1").Value
    nbreOcc = Sheets("resultats").Range("f1").Value
    Application.ScreenUpdating = False
    Sheets("Feuil1").Cells.Clear
    With Sheets("Logs")
        lig = 2
        dLig = .Range("b" & Rows.Count).End(xlUp).Row
        Do While lig <= dLig - nbreOcc + 1
            For k = 1 To nbreOcc
                txt = txt & "," & .Cells(lig + k - 1, 2).Value
            Next
            txt = Mid$(txt, Len(",") + 1)
            If txt = identite Then
                n = n + 1
                .Cells(lig, 1).Resize(nbreOcc, 12).Copy Sheets("Feuil1").Cells(n, 1)
                lig = lig + nbreOcc
                n = n + nbreOcc
            Else
                lig = lig + 1
            End If
            txt = ""
        Loop
        If n = 0 Then MsgBox "aucune séquence n'a été trouvée"
    End With
    Application.ScreenUpdating = True
End Sub

C'est tout bon maintenant

klin89

Merci Klin89 de ta persévérance et de ton soucis de perfection.

Très remarquable et hautement apprécié pour ton implication

En un Mot MERCI !!!!

Dans mon extraction je me suis rendu compte d'un petit Pb qui est le mélange de série.

En gros si je veux 2,7,15 en liste unique existante dans onglet "logs" ça marche

si cela devient 15,7,2 ou 7,2,15 ou 2,15,7 ou 7,15,2 etc.... qui veux dire la même chose

alors pas de remonté car ne correspond pas a la série !C1 de "résultats"

as-tu une idée?

Encore merci pour ton support et tes lumières

Bien cordialement et respectueusement

Re barachoie

Pour effectuer la comparaison des chaînes, j'ai procéder à un tri des occurences en amont, je pense que c'est le plus simple.

Option Explicit
Sub test()
Dim txt As String, identite As String, nbreOcc As Byte, MyArray1, MyArray2
Dim dLig As Long, lig As Long, n As Long
    nbreOcc = Sheets("resultats").Range("f1").Value
    Application.ScreenUpdating = False
    Sheets("Feuil1").Cells.Clear
    With Sheets("Logs")
        lig = 2
        dLig = .Range("b" & Rows.Count).End(xlUp).Row
        Do While lig <= dLig - nbreOcc + 1
            If nbreOcc > 1 Then
                MyArray1 = Application.Transpose(.Range(.Cells(lig, 2), .Cells(lig + nbreOcc - 1, 2)).Value)
                MyArray1 = BubbleSrt(MyArray1): txt = Join(MyArray1, ",")
                MyArray2 = Split(Sheets("resultats").Range("c1").Value, ",")
                MyArray2 = BubbleSrt(MyArray2): identite = Join(MyArray2, ",")
            Else
                txt = .Cells(lig, 2).Value: identite = Sheets("resultats").Range("c1").Value
            End If
            If txt = identite Then
                n = n + 1
                .Cells(lig, 1).Resize(nbreOcc, 12).Copy Sheets("Feuil1").Cells(n, 1)
                lig = lig + nbreOcc
                n = n + nbreOcc
            Else
                lig = lig + 1
            End If
            txt = ""
        Loop
        If n = 0 Then MsgBox "aucune séquence n'a été trouvée"
    End With
    Application.ScreenUpdating = True
End Sub

Public Function BubbleSrt(ArrayIn)
Dim SrtTemp As Variant, i As Long, j As Long
    For i = LBound(ArrayIn) To UBound(ArrayIn)
        For j = i + 1 To UBound(ArrayIn)
            If ArrayIn(i) > ArrayIn(j) Then
                SrtTemp = ArrayIn(j)
                ArrayIn(j) = ArrayIn(i)
                ArrayIn(i) = SrtTemp
            End If
        Next j
    Next i
    BubbleSrt = ArrayIn
End Function

klin89

Excellent Klin89

Dans sa forme Actuel ça marche !!!! simplement quand je le met dans mon fichier final

le BubbleSrt(ArrayIn) ne fonctionne pas a t-il un emplacement précis ?

Mon vraie Tri ce passe sur la colonne C de "logs" et non B

en remplaçant B par C dLig = .Range("c" & Rows.Count).End(xlUp).Row

et bien il continue a lire la colonne B

en tout cas tu es fortiche et je t'en félicite

Merci

Re barachoie

remplace cette ligne :

MyArray1 = Application.Transpose(.Range(.Cells(lig, 2), .Cells(lig + nbreOcc - 1, 2)).Value)

par :

MyArray1 = Application.Transpose(.Range(.Cells(lig, 3), .Cells(lig + nbreOcc - 1, 3)).Value)

et celle ci

Else
    txt = .Cells(lig, 2).Value: identite = Sheets("resultats").Range("c1").Value
End If

par

Else
    txt = .Cells(lig, 3).Value: identite = Sheets("resultats").Range("c1").Value
End If

klin89

Merci !!!!!!

C'est avec un grand plaisir que je Salue ton talent

Daniel