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

seb555 · 1 Novembre 2022

Bonjour,

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

VB:

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 · 1 Novembre 2022

Jean-Eric à dit:

Bonjour,
Une proposition 365 et +.
Cdlt.

VB:

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 · 1 Novembre 2022

bhbh à dit:
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 · 1 Novembre 2022

bhbh à dit:
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 :

VB:

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 · 1 Novembre 2022

Bonsoir

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

Alors puisque c'est pondu, je poste

VB:

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

VB:

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 · 1 Novembre 2022

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 · 2 Novembre 2022

Bonsoir @patricktoulon

patricktoulon à dit:
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 · 2 Novembre 2022

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

VB:

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 · 2 Novembre 2022

Bonjour,

Jean-Eric à dit:
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 · 2 Novembre 2022

Bonjour @bhbh ,

bhbh à dit:
avec 2 Dictionary..

Pourquoi donc deux dictionaries et pas un seul ?

Cousinhub · 2 Novembre 2022

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 · 2 Novembre 2022

Re @bhbh,

bhbh à dit:
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:

VB:

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

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

seb555

XLDnaute Nouveau

seb555

XLDnaute Nouveau

dysorthographie

XLDnaute Accro

seb555

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

Jean-Eric

XLDnaute Occasionnel

Pièces jointes

Cousinhub

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Discussions similaires