XL 2010 Compter automatiquement le nombre de valeurs uniques

[Cool762]

Bonjour la team,

Je reviens vers vous ce jour pour avoir votre aide sur un sujet qui me fatigue depuis un moment.
J'aimerais calculer automatiquement le nombre de valeurs distinctes d'une colonne.


Alors le bémol c'est que certaines cellules de la colonne contiennent 2, 3 voire 4 valeurs séparées par une virgule. J'ai essayé d'utiliser l'onglet "convertir" dans le groupe DONNEES d'excel pour fractionner les cellules ayant plusieurs valeurs à l'intérieur. Mais je maitrise pas vraiment et cela me prend vraiment de temps.

Alors certainement vous avez une formule pour aller plus vite ou une macro qui pourra m'aider à déterminer ce nombre.
Pour plus d'informations , n'hesitez pas a me le demander.
Dans mon cas, j'essaie de determiner le nombre de containers distinctes dans une semaine (colonne N en orange).
Je laisse un exemple du fichier excel sur lequel je travaille.


Merciii ds'avance.

 

[laurent950]

Bonjour
En Cellule AN3 Pour CAIU6270978 (C'est 1 ou 2 centenaires) / Pour la ligne 9 et 16 ?

 

[Cool762]

Bonjour
En Cellule AN3 Pour CAIU6270978 (C'est 1 ou 2 centenaires) / Pour la ligne 9 et 16 ?

Bonjour Laurent,

En cellule AN3, je voudrais avoir juste le nombre de conteneurs disctincts.
cette valeur par contre CAIU6270978 se repete 2 fois cme tu l'as remarqué. Mais dans les calculs je ne souhaite que compter une foiscette valeur ainsi que pour tous les autres se répetant. Mon objectif est de compter sans les doublons. je ne sais pas si je repond à ta question.

 

[Cool762]

On va essaie

Option Base 1
Sub NbContenaires()
Dim tabNb() As Variant
Dim T As Variant
Dim i As Double
Dim j As Integer
ReDim tabNb(1)
    For i = Cells(7, 14).Row To Cells(Cells(65536, 1).End(xlUp).Row, 14).Row
        If Cells(i, 14) Like "*" & "," & "*" Then
            T = Split(Cells(i, 14), ",")
            For j = LBound(T) To UBound(T)
                tabNb(i - 6) = T(j)
                ReDim Preserve tabNb(UBound(tabNb) + 1)
            Next j
        Else
            tabNb(i - 6) = Cells(i, 14)
            ReDim Preserve tabNb(UBound(tabNb) + 1)
        End If
    Next i
' TestDoublon
    Cells(3, 40) = TestDoublon(tabNb)
End Sub
Function TestDoublon(ByRef tabNb() As Variant) As Double
Dim nb As Double
    For i = LBound(tabNb) To UBound(tabNb)
        For j = i + 1 To UBound(tabNb)
            If tabNb(i) = tabNb(j) Then
                tabNb(j) = ""
            End If
        Next j
    Next i
    For i = LBound(tabNb) To UBound(tabNb)
        If tabNb(i) <> "" Then
            nb = nb + 1
        End If
    Next i
TestDoublon = nb
End Function

Bonjour,
J'ai essayé de mettre ce code a l'interieur d'un bouton de commande mais il ne fonctionne pas malheureusement.
Tu as pu l'intégrer dans le fichier? le test est est il concluant?

Merci pr ton retour

 

[Cool762]

Bonjour oui le test est très concluant
J'ai essayé de mettre ce code a l’intérieur d'un bouton de commande (Cela veux dire quoi ?) mais il ne fonctionne pas malheureusement.
envoyer le fichier je vais le mettre

Ci joint Laurent.

 

[Cool762]

J'ai légèrement Modifier le code et je l'ai transformé en fonction :
=NbContenaires(N7:N414)
La Fonction = NbContenaires / Ensuite il faut choisir la plage au choix ! ici de N7 a N414
Le résultat c'est le nombre trouvé sans doublon !

' Vous avez envie d'une Option qui fonctionne sur les lignes Filtrés comme avec votre fonction Sous-Total ?

Option Base 1
Function NbContenaires(ByRef Res As Range)
Dim tabNb() As Variant
Dim T As Variant
Dim i As Double
Dim j As Integer
ReDim tabNb(1)
    'For i = Cells(7, 14).Row To Cells(Cells(65536, 1).End(xlUp).Row, 14).Row
    For i = Res.Row To ((Res.Row + Res.Rows.Count) - 1)
        If Cells(i, 14) Like "*" & "," & "*" Then
            T = Split(Cells(i, 14), ",")
            For j = LBound(T) To UBound(T)
                tabNb(i - 6) = T(j)
                ReDim Preserve tabNb(UBound(tabNb) + 1)
            Next j
        Else
            tabNb(i - 6) = Cells(i, 14)
            ReDim Preserve tabNb(UBound(tabNb) + 1)
        End If
    Next i
' TestDoublon
    'Cells(3, 40) = TestDoublon(tabNb)
    NbContenaires = TestDoublon(tabNb)
End Function
Function TestDoublon(ByRef tabNb() As Variant) As Double
Dim nb As Double
    For i = LBound(tabNb) To UBound(tabNb)
        For j = i + 1 To UBound(tabNb)
            If tabNb(i) = tabNb(j) Then
                tabNb(j) = ""
            End If
        Next j
    Next i
    For i = LBound(tabNb) To UBound(tabNb)
        If tabNb(i) <> "" Then
            nb = nb + 1
        End If
    Next i
TestDoublon = nb
End Function

Wahou, le code marche bien.
Oui j'aimerais bien une option sur les lignes filtrées.
Merci de ton retour et du fichier final.

Cdt/

 

[Cool762]

Je renvoie le fichier test. Pour info

 

[laurent950]

Bonjour Voila la résultat :

Fonction sans Filtre : =NbContenaires(N7:N414)

Option Base 1
Function NbContenaires(ByRef Res As Range)
Dim tabNb() As Variant ' Variable tableau
Dim T As Variant ' Variable tableau
Dim i As Double
Dim j As Integer
ReDim tabNb(1) ' Dimension de la variable tableau 1 Case
    'For i = Cells(7, 14).Row To Cells(Cells(65536, 1).End(xlUp).Row, 14).Row
1er ligne de la plage : Res.Row et dernière ligne de la plage : ((Res.Row + Res.Rows.Count) - 1)
For i = Res.Row To ((Res.Row + Res.Rows.Count) - 1)
        If Cells(i, Res.Column) Like "*" & "," & "*" Then ' Condition si la chaîne Caractère contient une virgule = ,
            T = Split(Cells(i, Res.Column), ",") ' Découpage de la chaîne Split envoyé dans la variable tableau T
            For j = LBound(T) To UBound(T) ' Boucle sur le Tableau T (Toutes les cases)
                tabNb(UBound(tabNb)) = T(j) ' Copie du résultat dans la variable tableau tabNb dimensionné plus haut.
                ReDim Preserve tabNb(UBound(tabNb) + 1) ' Ajout d'une nouvelle case pour la variable tableau tabNb soit +1 Case
            Next j
        Else
            tabNb(UBound(tabNb)) = Cells(i, Res.Column)  ' chaîne sans séparateur virgule stocké dans la variable tableau tabNb
            ReDim Preserve tabNb(UBound(tabNb) + 1) 'Ajout d'une nouvelle case pour la variable tableau tabNb soit +1 Case
        End If
    Next i
ReDim Preserve tabNb(UBound(tabNb) - 1) ' Suppression d'une case inutile de la variable tableau tabNb soit 1 case en moins  (Cause incrémentation de la boucle voir plus haut)
' TestDoublon
    'Cells(3, 40) = TestDoublon(tabNb)
    NbContenaires = TestDoublon(tabNb) ' ici Fonction TestDoublon avec l'envois du tableau tabNb afin de récupérer le résultat qui sera renvoyer dans excel
End Function
Function TestDoublon(ByRef tabNb() As Variant) As Double
Dim nb As Double
    For i = LBound(tabNb) To UBound(tabNb) ' Boucle sur toutes les cases du tableau
        For j = i + 1 To UBound(tabNb) '  Boucle sur toutes les cases du tableau a partir de la prochaine
            If tabNb(i) = tabNb(j) Then ' Compare si le résultat est déjà trouvé (il y aura une action)
                tabNb(i) = "" ' cette action et d'effacer le résultat de la case du tableau = voir indice i
            End If
        Next j
    Next i
    For i = LBound(tabNb) To UBound(tabNb) ' ici encore une boucle sur ce tableau
        If tabNb(i) <> "" Then ' une condition qui est de savoir si la case est non vide il y a une action a faire.
            nb = nb + 1 ' cette action et de compter les cases du tableau non vide
        End If
    Next i
TestDoublon = nb    ' ici je revois le Nombre obtenu dans la fonction plus haut (c'est a dire celle-ci NbContenaires = TestDoublon(tabNb) ) est comme dit renverra le résultat dans excel !
End Function

Fonction avec Filtre : =NbContenairesFiltré(N7:N414)

Option Base 1
Function NbContenairesFiltré(ByRef Res As Range)
Dim tabNb() As Variant
Dim T As Variant
Dim i As Double
Dim j As Integer
ReDim tabNb(1)
    'For i = Cells(7, 14).Row To Cells(Cells(65536, 1).End(xlUp).Row, 14).Row
    For i = Res.Row To ((Res.Row + Res.Rows.Count) - 1)
        If Rows(i).Hidden = False Then 'si ligne cachée passe (j'ai juste ajouté cette condition en complément qui fait l'action de ne rien faire si cette ligne est filtré (elle ignore cette ligne comme si elle n'existait pas...) donc elle fait rien
            If Cells(i, Res.Column) Like "*" & "," & "*" Then
                T = Split(Cells(i, Res.Column), ",")
                For j = LBound(T) To UBound(T)
                    tabNb(UBound(tabNb)) = T(j)
                    ReDim Preserve tabNb(UBound(tabNb) + 1)
                Next j
            Else
                tabNb(UBound(tabNb)) = Cells(i, Res.Column)
                ReDim Preserve tabNb(UBound(tabNb) + 1)
            End If
        End If  ' Ici c'est la fin de l'instruction décrite plus haut soit If Rows(i).Hidden = False Then)
    Next i
ReDim Preserve tabNb(UBound(tabNb) - 1)
' TestDoublon
    'Cells(3, 40) = TestDoublon(tabNb)
    NbContenairesFiltré = TestDoublonFiltré(tabNb)
End Function
Function TestDoublonFiltré(ByRef tabNb() As Variant) As Double
Dim nb As Double
    For i = LBound(tabNb) To UBound(tabNb)
        For j = i + 1 To UBound(tabNb)
            If tabNb(i) = tabNb(j) Then
                tabNb(i) = ""
            End If
        Next j
    Next i
    For i = LBound(tabNb) To UBound(tabNb)
        If tabNb(i) <> "" Then
            nb = nb + 1
        End If
    Next i
TestDoublonFiltré= nb
End Function