Microsoft 365 Transfert valeurs unique d'un Range dans un Array

[seb555]

Bonjour,

Je cherche à mettre les valeurs uniques de A3:A8 dans un Array, la façon que j'ai trouvé pour y arriver est

Sub test()
    Dim vars0() As Variant
    ReDim vars0(0)
    lali1 = 8
    Ini1 = False
    For i = 3 To lali1
        valeur = Cells(i, 1)
        On Error Resume Next
            x = Application.Match(valeur, vars0, 0)
            If Err.Number <> 0 Or x = "Erreur 2042" Then
                If Ini1 = True Then ReDim Preserve vars0(UBound(vars0) + 1)
                vars0(UBound(vars0)) = valeur
                Ini1 = True
            End If
        On Error GoTo 0
    Next
End Sub

Remarque ce cas va de 3 à 8 mais je vais généraliser de 3 à last line, c'est juste pour un test

Y a-t'il une façon plus simple de le faire, sans passer par la variable de passage Ini1 par exemple ?

Seb

 

[seb555]

Bonjour,
Une proposition 365 et +.
Cdlt.

Public Sub Test()
Dim r As Range, tbl As Variant, i As Long
    With ActiveSheet
        Set r = .Range("A3:A8")
        tbl = WorksheetFunction.Unique(r)
        For i = LBound(tbl) To UBound(tbl)
            Debug.Print tbl(i, 1)
        Next i
    End With
End Sub

Simple et efficace, cela tient en peu de ligne. Merci.

 

[dysorthographie]

Re-,
Je ne rentre dans aucune polémique...

Juste qu'il y a 48 espaces dans tes données...
Et qu'un Trim aurait peut-être été judicieux...

Avec adWChar il n'y a plus d'espace en trop!

 

[seb555]

Re-,
Je ne sais pas pour toi, mais le code de @dysorthographie me donne AB suivi de 48 espaces...
Ainsi que CN...
Ceci est dû à la longueur imposée de 50 caractères :

Rs.Fields.Append "A", adChar, 50: Rs.Open

Et donc, qui ne supporterait pas des cellules de + de 50 caractères

C'est exact, mais dysorthographie a déjà donné réponse à ce point. Sinon, ok pour RTrim.

 

[Staple1600]

Bonsoir

Jean-Eric m'a devancé mais j'étais parti sur la même piste

Alors puisque c'est pondu, je poste

Sub Test_OK()
Dim r As Range: Set r = Cells(1).CurrentRegion
    With Application
        [B1].Resize(UBound(.Unique(r), 1)).Value = .Unique(r)
    End With
End Sub

Ci-dessous macro pour générer des données de test

Sub Pour_TEST()
Range("A2:A40").FormulaR1C1 = "=INT(ROW(R[-1]C)/RANDBETWEEN(2,5))+1"
Range("A2:A40") = Range("A2:A40").Value
End Sub

 

[patricktoulon]

bonsoir
en tout cas la demande est confuse
je cite

Je cherche à mettre les valeurs uniques de A3:A8 dans un Array, la façon que j'ai trouvé pour y arriver est

pour moi ca veut dire les valeurs uniques (celles qui n'ont pas de doublons) et pas une liste(array)sans les doublons

 

[mapomme]

Bonsoir @patricktoulon

en tout cas la demande est confuse
je cite
pour moi ca veut dire les valeurs uniques (celles qui n'ont pas de doublons)

Pour ce cas, on peut parler de singleton.
Le problème est différent. Un exemple dans le fichier joint avec 150 000 lignes dans la source dont 111 valeurs "singletons". La durée d'exécution est d'environ 0,42s.
L'initialisation de la source se fait à l'ouverture du fichier.
Le code est dans le module de Feuil1.

 

[Jean-Eric]

Bonjour,
Pour donner suite, 2 propositions pour lister les valeurs distinctes et uniques.
Cdlt.

Public Sub DistinctValues()
'occurence > 1
Dim r As Range, tbl As Variant, i As Long
    With Sheet1
        Set r = .Range("A3:A14")
        tbl = WorksheetFunction.Unique(r)
        For i = LBound(tbl) To UBound(tbl)
            Debug.Print tbl(i, 1)
        Next i
    End With
End Sub

Public Sub UniqueValues()
'occurence = 1
Dim r As Range, tbl As Variant, i As Long
    With Sheet1
        Set r = .Range("A3:A14")
        tbl = WorksheetFunction.Unique(r, , True)
        For i = LBound(tbl) To UBound(tbl)
            Debug.Print tbl(i, 1)
        Next i
    End With
End Sub

 

[Cousinhub]

Bonjour,

Bonjour,
Pour donner suite, 2 propositions pour lister les valeurs distinctes et uniques.
Cdlt.

Public Sub UniqueValues()
'occurence = 1
Dim r As Range, tbl As Variant, i As Long
With Sheet1
Set r = .Range("A3:A14")
tbl = WorksheetFunction.Unique(r, , True)
For i = LBound(tbl) To UBound(tbl)
Debug.Print tbl(i, 1)
Next i
End With
End Sub[/CODE]

Bien plus rapide qu'un Dictionary...
8 centièmes de seconde sur le fichier @mapomme pour cette fonction Unique, contre 22 centièmes avec 2 Dictionary..

 

[mapomme]

Bonjour @bhbh ,

avec 2 Dictionary..

Pourquoi donc deux dictionaries et pas un seul ?

 

[Cousinhub]

Re-,
Le premier pour charger les valeurs sans doublons, et qui est chargé comme ceci :
Dict(tbl(i,1))=Dict(tbl(i,1)) +1
Ainsi, je récupère le nombre de répétitions de chaque valeur dans les items
Puis le deuxième qui parcourt le 1er, et qui ne récupère que les clés dont l'item est à 1..
Voili, voilou...

 

[mapomme]

Re @bhbh,

Puis le deuxième qui parcourt le 1er, et qui ne récupère que les clés dont l'item est à 1..

Ok, j'ai compris.
Souvent, je n'en utilise qu'un seul. C'est à cause de mon âge car dans ma jeunesse on devait économiser la quantité de RAM utilisée, c'était rare et précieux la RAM.

Avec un seul dictionary pour fabriquer le tableau (mais non compatible MAC), on pourrait faire:

Sub Singleton1()
Dim deb, t, dico, x, q&
   deb = Timer
   t = Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
   Set dico = CreateObject("scripting.dictionary")
   For Each x In t: dico(x) = dico(x) + 1: Next
   For Each x In dico
      If dico(x) = 1 Then q = q + 1 Else dico.Remove x
   Next x
   If q > 0 Then
      ReDim r(1 To q, 1 To 1): q = 0
      For Each x In dico
         If dico(x) = 1 Then q = q + 1: r(q, 1) = x
      Next x
   End If
   MsgBox Format(Timer - deb, "0.00\ sec.")
End Sub