Convertir private sub en fonction

[kingfadhel]

Bonjour tout le monde,
SVP, est ce possible de convertir un private sub en une fonction personnalisée??

Sub UniqueValuesCopy()
    Dim iArray As Variant
    Dim RowCount As Long
    With Sheet2
        Sheets("Unique").Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("D2"), Unique:=True
        RowCount = .Cells(.Rows.Count, "B").End(xlUp).Row
        iArray = .Range("B5:B" & RowCount)
    End With
    Dim iValue As String
    Dim i As Integer
    For i = 1 To UBound(iArray)
        iValue = iValue & iArray(i, 1) & ","
    Next
End Sub

 

[fanch55]

Bonjour,
Si vous pouviez expliquer ce que vous voulez faire avec la sub car je n'en ai pas compris la finalité.
Si vous voulez une fonction personnalisée, que doit renvoyer celle-ci ?
Cette fonction doit-elle être de type Macro ( appelable par bouton ou code) ou Formule ( à placer dans une cellule ) ?

 

[Dranreb]

Bonjour.

Function UniqueNonClassé(ByVal Rng As Range) As Variant()
   Dim T(), L&, Cln As New Collection
   T = Rng.Value
   On Error Resume Next
   For L = 1 To UBound(T, 1)
      Cln.Add T(L, 1), T(L, 1)
      Next L
   For L = 1 To Cln.Count
      T(L, 1) = Cln(L)
      Next L
   Do While L <= UBound(T, 1)
      T(L, 1) = "": L = L + 1: Loop
   UniqueNonClassé = T
   End Function

En D3:D19 validé par Ctrl+Maj+Entrée :

=UniqueNonClassé($B3:$B$19)

 

[Compte Supprimé 979]

Bonjour à tous,

@kingfadhel vous n'avez pas indiqué votre version d'Excel

Pour info, avec une simple formule, vous pouvez le faire

=UNIQUE(TblReference49[Student Name])

A+

​

 

[fanch55]

Bonjour à tous,
Moi je suis en Xl 2019 :
Au vu de la feuille excel, j'ai également vu une extraction sans doublon mais je ne comprend toujours pas tout le code fourni au post #1: pourquoi un iarray concaténant tous les éléments de la table à partir de la ligne 5 de celle-ci ?

@Dranreb, avec ton code , j'obtiens ceci avec Ctrl+Maj+Entrée ou non ?

 

[JHA]

Bonjour à tous,

Avec la version 2019, tu as également dans le ruban onglet "Données" puis supprimer les doublons

JHA

 

[patricktoulon]

Bonjour à tous
a valider en matriciel en dessous 2019

Function unique2007(r As Range)
    Dim c As New Collection, Lig&, a&
    If r.Rows.Count = Rows.Count Then Set r = r.Resize(Cells(Rows.Count, r.Column).End(xlUp).Row)
    t = r.Value
    ReDim t2(1 To UBound(t), 1 To 1)
    For Lig = 1 To UBound(t)
        t2(Lig, 1) = ""
        If t(Lig, 1) <> "" Then
            On Error Resume Next
            c.Add t(Lig, 1), t(Lig, 1)
            If Err.Number = 0 Then a = a + 1: t2(a, 1) = t(Lig, 1)
        End If
        Err.Clear
    Next Lig
       unique2007 = t2
End Function

 

[Dranreb]

@Dranreb, avec ton code , j'obtiens ceci avec Ctrl+Maj+Entrée ou non ?

Non, ça c'est ce qu'on obtient en validant la première cellule seulement puis en la propageant, pas en validant en matriciel l'ensemble de la plage.

 

[fanch55]

Non, ça c'est ce qu'on obtient en validant la première cellule seulement puis en la propageant, pas en validant en matriciel l'ensemble de la plage.

Exact, je croyais l'avoir fait, la preuve que non ....

 

[fanch55]

Bonjour à tous
a valider en matriciel en dessous 2019

Fonctionne également avec 2019

 

[fanch55]

Une autre fonction à valider également par Ctrl+Maj+Entrée :
N'apporte rien de plus sauf la possibilité de trier la liste :

Function Unique2019(R As Range, Optional ToSort As Boolean = False)
    Dim Cl As Range
    Dim Arl As Object: Set Arl = CreateObject("System.Collections.ArrayList")
    For Each Cl In R
        If Not Arl.contains(Cl.Value) Then Arl.Add Cl.Value
    Next
    If ToSort Then Arl.Sort
    
    Dim T(), I, J: T = Arl.toarray: J = UBound(T) + 1
    ReDim Preserve T(R.Rows.Count): For I = J To UBound(T): T(I) = "": Next
    
    Unique2019 = Application.Transpose(T)
End Function

 

[patricktoulon]

re
a ben ça fait longtemps qu'on les a pas vu les sytemarraylist et systemsortedlist

 

[mapomme]

Bonjour à tous ,

Comme @fanch55 l'a si bien dit, une fonction :

• Prend un certain nombre de données (le plus souvent) en entrée (les arguments) mais quelles sont elles dans votre cas ?
• Retourne quelque chose qui peut être un nombre, une plage, un tableau, une chaine de caractères, un objet et que sais je encore ? Dans votre cas que doit-on retourner ?

Votre macro se termine par la construction d'un string des valeurs (sans doublon) séparées par une virgule. C'est cela que doit retourner votre fonction ?

Sans ces indications, on peut en discuter pendant 107 ans...

 

[Dranreb]

Bonjour.
Ah oui, je n'avais pas vu.

Function ListeNonClassée(ByVal Rng As Range) As String
   Dim TV(), TJn() As String, L&, Cln As New Collection
   T = Rng.Value
   On Error Resume Next
   For L = 1 To UBound(T, 1)
      Cln.Add T(L, 1), T(L, 1)
      Next L
   ReDim TJn(1 To Cln.Count)
   For L = 1 To Cln.Count
      TJn(L) = Cln(L)
      Next L
   ListeNonClassée = Join(TJn, ", ")
   End Function

Validé normalement cette fois dans la cellule où on le veut :

=ListeNonClassée(TblReference49[Student Name])

Pour une version classé de la liste j'utiliserais la fonction SujetCBx de mon module MSujetCBx décidément très pratique pour établir des listes classées et sans doublon, avec en plus un second volet contenant les listes des numéros de lignes où a été trouvée chaque valeur du premier volet.

Edition: le plus surprenant c'est qu'elle l'établit en une seule instruction :

Function ListeClassée(ByVal Rng As Range) As String
   ListeClassée = Join(SujetCBx(Rng)(0), ", ")
   End Function

Je ne m'attendais pas vraiment à ce que ça marche parce que l'élément 0 du Sujet est un tableau basé 0 de Variant alors que d'habitude je spécifie un tableau de String à la fonction VBA.Join.

 

[mapomme]

Re,

Ma p'tite version toute simplette (on retire les cellules "vides ou ne contenant que des espaces"; on ne distingue pas minuscule et majuscule) :

Function Liste$(ByVal Rng As Range)
 Dim t, c$, x, a$, s$, res$
   c = Asc(0): t = Rng.Value
   For Each x In t
      If Trim(x) <> "" Then
         a = c & x & c
         If InStr(1, s, a, vbTextCompare) = 0 Then res = res & "," & x: s = s & a
      End If
   Next x
   Liste = Mid(res, 2)
End Function