Recherche & référence UniqueSOLO

patricktoulon · 10 Février 2022

re
me revoilà avec la petite UniqueSOLO
dans la ligné de mes deux précédentes c'est une fonction de tri de doublons
mais cette fois ci elle ne récupère que les one shot c'est à dire uniquement ceux qui apparaissent qu'une seule fois
et pareil que pour la UNIQUEx on tri par la colonne 1 ou 2
en matricielle toujours et pareil vous avez la macroOptions descriptions

VB:

'***************************************************************************
'                 Collection fonction doublons                             *
' Fonction "UniqueSOLO"                                                    *
' filter les doublons d'une plage de deux colonnes par la colonne (1 ou 2) *
' récupere uniquement les valeurs qui n'existent q'une seule fois!!        *
' dans la plage et colonne désignée                                        *
' auteur :patricktoulon                                                    *
' date 09/02/2022                                                          *
' version 1.0                                                              *
'***************************************************************************

Option Explicit
Function UniqueSOLO(RNG As Range, Optional col& = 0)
    Dim T, dic1 As Object, dic2 As Object, I&, a&, t2, K, It, kx, itX, itx2, Col2: T = RNG.Value
    Set dic1 = CreateObject("Scripting.Dictionary"):    Set dic2 = CreateObject("Scripting.Dictionary")
    If col = 0 Then col = 1
    If col = 1 Then Col2 = 2 Else Col2 = 1
    T = RNG.Resize(RNG.Rows.Count, 2)
    For I = 1 To UBound(T): dic1(T(I, col)) = T(I, Col2): dic2(T(I, col)) = Val(dic2(T(I, col))) + 1: Next
    K = dic1.keys: It = dic1.items: kx = K: itX = It: itx2 = dic2.items
    If col = 2 Then kx = It: itX = K
    ReDim t2(1 To Application.Caller.Rows.Count, 1 To 2)
    For I = 1 To UBound(t2)
        t2(I, 1) = "": t2(I, 2) = ""
        If I <= UBound(kx) + 1 Then
            If itx2(I - 1) <= 1 Then a = a + 1: t2(a, 1) = kx(I - 1): t2(a, 2) = itX(I - 1)
        End If
    Next
    UniqueSOLO = t2
    Set dic1 = Nothing: Set dic2 = Nothing
End Function


Sub UnregisterOptions()
    On Error Resume Next
    Application.MacroOptions Macro:="UniqueSOLO", 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 UniqueSOLO " & vbCrLf & _
                        "Filtre doublons dans une plage 1/2 colonnes par la colonne 1 ou 2" & vbCrLf & _
                        "récupere les valeurs qui n'apparaissent qu'une seule fois" & vbCrLf & vbCrLf & _
                        "Collection Fonctions Persos Créated By patricktoulon 02/2022"

    'Description des arguments de la fonction
    argumtsArray = Array("Adresse de la colonne à trier ", _
                         "index de la colonne à extraire les doublons ")


    'appel  la sub pour enregistrer
    Application.MacroOptions Macro:="UniqueSOLO", _
                             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
'***************************************

Recherche & référence UniqueSOLO

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Discussions similaires