Recherche & référence DicoCountOrder

[patricktoulon]

Bonjour à tous
je vous propose aujourd'hui ma fonction perso "DicoCountOrder"
elle consiste à récupérer une colonne sans doublons mais en comptabilisant les doublons dans un tableau 2 colonnes(chaîne/nombres d’occurrence )
elle fonctionne en formule matricielle(à valider par CTRL+MAJ+ENTER pour les version inférieures à 365)
elle fonctionne aussi en VBA de la même manière
j'ai ajouté la macroOptions description(facultatif)

Option Explicit
'****************************************************************************************
'collection fonction perso catégorie:texte et tableau
'fonction dictionnaire et count occurence
'auteur :patricktoulon
'date :05/002/2022
'fonctionne en matricielle

'exemple de formule:
'=DicoAndCountOrder(A2:A26)         juste les chaines
'=DicoAndCountOrder(A2:A26)         les chaines et le nombre d'occurrences  sur 2 colonnes  dans l'ordre d'inscription dans le dico
'=DicoAndCountOrder(A2:A26;2;1)     trier par le nombre de récurences décroissant
'=DicoAndCountOrder(A2:A262;2)      trier par le nombre de récurences croissant
'=DicoAndCountOrder(A2:A26;1;2)     trier par ordre alphabétique  croissant
'=DicoAndCountOrde(A2:A26,1,1)      trier par orde alphabétique  décroissant

'toutes les formule  peuvent etre utilise sur une seul colonne
'on aura alors que les chaînes trier selon les formules
 
'la  fonction est accompagné de ma petite fonction tribulle4(tri à bulle)
'****************************************************************************************
Function DicoCountOrder(Source As Variant, Optional colonne_de_tri As Long = 0, Optional sens_du_tri As Long = 0)
'Source est une plage de cellules ou une matrice en base 1
    Debug.Print 1
    Dim nlig&, ncol%, tablo, i&, j%, Dico As Object, K, It
    Set Dico = CreateObject("Scripting.Dictionary")

    Source = Source    'conversion automatique range to variant( c'est tout bète) Merci @Job75
    If Not IsArray(Source) Then MsgBox "cette fonction doit avoir comme source un array2 dim (x ligne et 1 colonne)" & vbCrLf & "ou la colonne d'une plage": DicoCountOrder = "": Exit Function
    nlig = UBound(Source): ReDim tablo(1 To nlig + 3, 1 To 2)

    On Error Resume Next
    ReDim tablo(1 To Application.Caller.Rows.Count + 1, 1 To 2)
    On Error GoTo 0

    For i = 1 To UBound(Source): Dico(Source(i, 1)) = Val(Dico(Source(i, 1))) + 1: Next: K = Dico.keys: It = Dico.items

    For i = 1 To UBound(tablo)
        If i <= (UBound(K) + 1) Then tablo(i, 1) = K(i - 1): tablo(i, 2) = It(i - 1) Else tablo(i, 1) = "": tablo(i, 2) = ""
    Next i
    If sens_du_tri& + colonne_de_tri& > 0 Then tablo = TriBulle4(tablo, colonne_de_tri&, sens_du_tri)
    DicoCountOrder = tablo
End Function

'fonction tribulle optionel
Function TriBulle4(tabl, col, Optional sens = 0)
    Dim i#, e#, X#
    If sens = 0 Then TriBulle4 = tabl
    ReDim temp(UBound(tabl, 2))
    For i = 1 To UBound(tabl)
        If tabl(i, 1) = "" Then Exit For
        For e = i + 1 To UBound(tabl)
            If tabl(e, 2) = "" Then Exit For
            Select Case sens
            Case 1
                If tabl(e, col) > tabl(i, col) Then For X = 1 To UBound(tabl, 2): temp(X) = tabl(i, X): tabl(i, X) = tabl(e, X): tabl(e, X) = temp(X): Next
        Case 2
            If tabl(e, col) < tabl(i, col) Then For X = 1 To UBound(tabl, 2): temp(X) = tabl(i, X): tabl(i, X) = tabl(e, X): tabl(e, X) = temp(X): Next
    End Select
Next
Next
TriBulle4 = tabl
End Function

pour la macroOptions description(facultatif)

Sub UnregisterOptions()
    On Error Resume Next
    Application.MacroOptions Macro:="DicoCountOrder", Description:=Empty, ArgumentDescriptions:=Empty, Category:=Empty
    On Error GoTo 0
End Sub

Sub registerOptions()
    Dim Funct_description As String, argumtsArray

    '(max 255 caracteres)
    Funct_description = "Fonction Matricielle Dictionnaire " & vbCrLf & _
                        "Le tableau renvoyé a 1 ou 2 colonnes(chaine est nombres d'occurences" & vbCrLf & _
                        "Tri alphabetique ou par le nombres d'occurences" & vbCrLf & _
                        "Par ordre croissant ou decroissant" & vbCrLf & _
                        "Créated By patricktoulon"

    'Description des arguments de la fonction
    argumtsArray = Array("Adresse de la colonne à trier ", _
                         "1 pour tri chaîne  : 2 ou par le nombres d'ocurrences", _
                         "1 pour tri décroisant   /   2 pour tri croissant ")

    'appel  la sub pour enregistrer
    Application.MacroOptions Macro:="DicoCountOrder", _
                             Description:=Mid(Funct_description, 1, 255), _
                             ArgumentDescriptions:=argumtsArray, _
                             Category:="personnalisée"
End Sub


'***************************************
'a mettre dans l'open si on veut la description  et le formulaire de fonction
Sub auto_open(): registerOptions: End Sub
Sub auto_close(): UnregisterOptions: End Sub
'***************************************

démo de la fonction
utilisation vba

utilisation en matricielle