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

seb555

XLDnaute Nouveau
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
 
Dernière édition:

seb555

XLDnaute Nouveau
Bonjour Seb555

J'ai dû louper quelque chose 🤔
VB:
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.
 

dysorthographie

XLDnaute Accro
Bonjour,
VB:
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

XLDnaute Barbatruc
Supporter XLD
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:
VB:
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.
 

Pièces jointes

  • seb555- array sans doublon- v1.xlsm
    21 KB · Affichages: 2
Dernière édition:

Cousinhub

XLDnaute Barbatruc
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 :
VB:
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

XLDnaute Nouveau
Bonjour,
VB:
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

XLDnaute Nouveau
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:
VB:
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

XLDnaute Nouveau
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 :
VB:
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
 

dysorthographie

XLDnaute Accro
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
oui mais tu as le choix par exemple!
VB:
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!

 

Cousinhub

XLDnaute Barbatruc
Re-,
Je ne rentre dans aucune polémique...
oui mais tu as le choix par exemple!
VB:
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!

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

Discussions similaires

Réponses
0
Affichages
83