patricktoulon
XLDnaute Barbatruc
Bonjour a tous dans la lignée de DicoCountOrder
ne l'ayant pas parce que je suis 2013 je vous propose aujourd'hui la petite( UNIQUEx)
qui fait exactement ce que fait la fonction UNIQUE de 2016 et +
elle travaille sur 2 ou 1 colonne dans la récupération et peut filtrer par la colonne 1 ou 2
ne l'ayant pas parce que je suis 2013 je vous propose aujourd'hui la petite( UNIQUEx)
qui fait exactement ce que fait la fonction UNIQUE de 2016 et +
elle travaille sur 2 ou 1 colonne dans la récupération et peut filtrer par la colonne 1 ou 2
VB:
'***************************************************************************
' Collection fonction doublons *
' Fonction "UNIQUEx" *
' filter les doublons d'une plage de deux colonnes par la colonne (1 ou 2) *
' fonctionne comme son homologue "UNIQUE" des versions superieur à 2013 *
' auteur :patricktoulon *
' date 09/02/2022 *
' version 1.0 *
'***************************************************************************
Option Explicit
Function UNIQUEx(RNG As Range, Optional col& = 0)
Dim T, dic As Object, I&, t2, K, It, kx, itX, Col2: T = RNG.Value
Set dic = 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): dic(T(I, col)) = T(I, Col2): Next: K = dic.keys: It = dic.items: kx = K: itX = It
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)
If I <= UBound(kx) + 1 Then t2(I, 1) = kx(I - 1): t2(I, 2) = itX(I - 1) Else t2(I, 1) = "": t2(I, 2) = ""
Next
UNIQUEx = t2
End Function
Sub UnregisterOptions()
On Error Resume Next
Application.MacroOptions Macro:="UNIQUEx", 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 UNIQUEx " & vbCrLf & _
"Filtre doublons dans une plage 1/2 colonnes par la colonne 1 ou 2" & vbCrLf & _
"Remplace la fonction UNIQUE de 2016 et +" & vbCrLf & _
"Elle fonctionne aussi comme La UNIQUE(2016+)1 colonne" & 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:="UNIQUEx", _
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
'***************************************
