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

 

[Compte Supprimé 979]

Bonjour Seb555

J'ai dû louper quelque chose

Sub Test()
Dim Vars0() as Variant
Vars0 = range("A3:A8").Value

A+

 

[Cousinhub]

Bonjour,
@BrunoM45

Bonjour Seb555

J'ai dû louper quelque chose

Le mot "Unique", peut-être, dans la demande???

@seb555
Regarde peut-être du côté du Scripting.Dictionary?

 

[seb555]

Bonjour Seb555

J'ai dû louper quelque chose

Sub Test()
Dim Vars0() as Variant
Vars0 = range("A3:A8").Value

A+

C'est exact, mon explication n'était pas complète :

en fait je souhaite dans la zone A3:A8 par exemple ne garder que les valeurs uniques pour les mettre dans un Array.

Si la zone est composée de AB,AB,CN,CN,AB,CN alors le Array aura AB et CN comme éléments.

 

[seb555]

Bonjour,
@BrunoM45

Le mot "Unique", peut-être, dans la demande???

@seb555
Regarde peut-être du côté du Scripting.Dictionary?

Non, j'ai précisé le problème, la remarque de Bruno était correcte, je cherche à mettre dans le Array que les valeurs uniques, non connues d'avance.

 

[dysorthographie]

Bonjour,

Sub Test()
Const adChar = 129
Dim Rs As Object, vars0() As Variant, C As Range
Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "A", adChar, 50: Rs.Open
For Each C In Sheets("Feuil1").Range("A1:A8")
    Rs.Filter = "[A]='" & Replace(C, " '", "''") & "'"
    If Rs.EOF Then Rs.AddNew
    Rs("A") = C.Value
    Rs.Update
Next
 Rs.Filter = ""
 Rs.MoveFirst
 Rs.Sort = "[A]"
 vars0() = Application.Transpose(Application.Transpose(Rs.GetRows))
End Sub

 

[mapomme]

Bonjour à tous,

L'array résultat RES est un array à une seule dimension. On n'utilise pas de "dictionary" donc le code reste compatible avec les MAC. Le code devrait fonctionner avec toutes les versions de Excel à/c de 2010.

remarque: Il est très rare d'utiliser un array simple dans les codes quand on lit un tableau à partir d'une plage. Dans ce cas, la boucle devient inutile -> le tableau résultat est directement t2 sans être obligé de passer par le tableau Res.

Code à placer dans me module de la feuille concernée:

Sub EnArray()
Dim n&, t1, t2, i&, res
   t1 = Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row)      ' lecture des données initiales
   Range("a3").Resize(UBound(t1)).RemoveDuplicates Columns:=1, Header:=xlNo   'on ôte les doublons
   t2 = Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row)      ' lecture  des données sans doublons
   Range("a3").Resize(UBound(t1)) = t1                            ' on replace les données initiales
   Erase t1: ReDim res(1 To UBound(t2))                           ' on supprime t1 et on dimensionn ele tableau final
   For i = 1 To UBound(t2): res(i) = t2(i, 1): Next               ' on remplit res avec les valeurs de t2
End Sub

Avec un fichier pour tester différents jeux de valeurs. Cliquer sur un des trois boutons Jeu.

 

[Cousinhub]

Non, j'ai précisé le problème, la remarque de Bruno était correcte, je cherche à mettre dans le Array que les valeurs uniques, non connues d'avance.

Re-,
C'était bien l'objet de ma petite remarque...
Et en suivant le lien fourni, tu aurais pu obtenir un code dans le genre :

Sub uniq()
Dim Cel As Range
Dim Val_Uniq As Object
Dim Tbl
Set Val_Uniq = CreateObject("Scripting.Dictionary")
For Each Cel In Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    Val_Uniq(Cel.Value) = Cel.Value
Next Cel
Tbl = Val_Uniq.keys
End Sub

Tes valeurs uniques sont dans Tbl
Bonne apm

 

[seb555]

Bonjour,

Sub Test()
Const adChar = 129
Dim Rs As Object, vars0() As Variant, C As Range
Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "A", adChar, 50: Rs.Open
For Each C In Sheets("Feuil1").Range("A1:A8")
    Rs.Filter = "[A]='" & Replace(C, " '", "''") & "'"
    If Rs.EOF Then Rs.AddNew
    Rs("A") = C.Value
    Rs.Update
Next
 Rs.Filter = ""
 Rs.MoveFirst
 Rs.Sort = "[A]"
 vars0() = Application.Transpose(Application.Transpose(Rs.GetRows))
End Sub

Merci pour cette proposition, qui en plus de la création d'unique recherchée les sorts par ordre croissant

 

[seb555]

Bonjour à tous,

L'array résultat RES est un array à une seule dimension. On n'utilise pas de "dictionary" donc le code reste compatible avec les MAC.

remarque: Il est très rare d'utiliser un array simple dans les codes quand on lit un tableau à partir d'une plage. Dans ce cas, la boucle devient inutile -> le tableau résultat est directement t2 sans être obligé de passer par le tableau Res.

Code à placer dans me module de la feuille concernée:

Sub EnArray()
Dim n&, t1, t2, i&, res
   t1 = Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row)      ' lecture des données initiales
   Range("a3").Resize(UBound(t1)).RemoveDuplicates Columns:=1, Header:=xlNo   'on ôte les doublons
   t2 = Range("a3:a" & Cells(Rows.Count, "a").End(xlUp).Row)      ' lecture  des données sans doublons
   Range("a3").Resize(UBound(t1)) = t1                            ' on replace les données initiales
   Erase t1: ReDim res(1 To UBound(t2))                           ' on supprime t1 et on dimensionn ele tableau final
   For i = 1 To UBound(t2): res(i) = t2(i, 1): Next               ' on remplit res avec les valeurs de t2
End Sub

Avec un fichier pour tester différents jeux de valeurs. Cliquer sur un des trois boutons Jeu.

C'est exact, j'aurais pu m'en sortir avec un t1=Range ... suivi d'un resize, en fait ce qui m'intriguait était l'utilisation d'un Array de taille 0 pour lequel il me semblait nécessaire de traiter l'affectation de la première valeur via une variable de passage(Ini1 dans mon cas) pour assurer le traitement adéquat.
Merci.

 

[seb555]

Re-,
C'était bien l'objet de ma petite remarque...
Et en suivant le lien fourni, tu aurais pu obtenir un code dans le genre :

Sub uniq()
Dim Cel As Range
Dim Val_Uniq As Object
Dim Tbl
Set Val_Uniq = CreateObject("Scripting.Dictionary")
For Each Cel In Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    Val_Uniq(Cel.Value) = Cel.Value
Next Cel
Tbl = Val_Uniq.keys
End Sub

Tes valeurs uniques sont dans Tbl
Bonne apm

En effet, cela faisait un petit moment que je n'avais pas touché de Dictionnary, l'astuce de donner à l'item sa propre valeur est intéressante. Merci

 

[Cousinhub]

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

 

[dysorthographie]

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

oui mais tu as le choix par exemple!

Const adWChar = 130
Dim Rs As Object, vars0() As Variant, C As Range
Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "A", adWChar, 255: Rs.Open

plus d'espace et tu peux aller à 255 quartaires! plus si tu veux!

DataTypeEnum - ActiveX Data Objects (ADO)

DataTypeEnum

learn.microsoft.com

 

[Jean-Eric]

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

 

[Cousinhub]

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

oui mais tu as le choix par exemple!

Const adWChar = 130
Dim Rs As Object, vars0() As Variant, C As Range
Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "A", adWChar, 255: Rs.Open

plus d'espace et tu peux aller à 255 quartaires! plus si tu veux!

DataTypeEnum - ActiveX Data Objects (ADO)

DataTypeEnum

learn.microsoft.com

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