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

Compte Supprimé 979 · 1 Novembre 2022

Bonjour Seb555

J'ai dû louper quelque chose

VB:

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

A+

Cousinhub · 1 Novembre 2022

Bonjour,
@BrunoM45

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

BrunoM45 à dit:
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.

seb555 · 1 Novembre 2022

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

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

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.

Cousinhub · 1 Novembre 2022

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

dysorthographie à dit:

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

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

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

Cousinhub · 1 Novembre 2022

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

dysorthographie · 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

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!

DataTypeEnum - ActiveX Data Objects (ADO)

DataTypeEnum

learn.microsoft.com

Jean-Eric · 1 Novembre 2022

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

Cousinhub · 1 Novembre 2022

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

dysorthographie à dit:
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!

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...

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

seb555

XLDnaute Nouveau

Compte Supprimé 979

Guest

Cousinhub

XLDnaute Barbatruc

seb555

XLDnaute Nouveau

seb555

XLDnaute Nouveau

dysorthographie

XLDnaute Accro

mapomme

XLDnaute Barbatruc

Pièces jointes

Cousinhub

XLDnaute Barbatruc

seb555

XLDnaute Nouveau

seb555

XLDnaute Nouveau

seb555

XLDnaute Nouveau

Cousinhub

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

DataTypeEnum - ActiveX Data Objects (ADO)

Jean-Eric

XLDnaute Occasionnel

Pièces jointes

Cousinhub

XLDnaute Barbatruc

DataTypeEnum - ActiveX Data Objects (ADO)

Discussions similaires