XL 2016 Réduction d'un array en fonction d'une condition (suppression doublons)

[Etxezarreta]

Bonjour,
Dans l'onglet "Données" du fichier ci-joint je souhaite épurer la colonne B de ses doublons, en passant par une variable tableau et en utilisant la fonction application.match, puis coller le nouveau array ainsi obtenu dans l'onglet "Resultat"
Le tri fonctionne bien, les 3 valeurs distinctes sont bien extraites et un array à trois ligne crée depuis l'array d'origine à 13 lignes. Par contre, lorsque je veux coller cet array à trois lignes en entier dans Excel, ce sont les trois mêmes valeurs qui apparaissent!! La solution doit être toute bête mais..
Merci de votre aide.
Etxe.

 

[Patrice33740]

Bonjour,

Avec :

With wksResultat
.Range("A1").Resize(UBound(arrVariableTableauDefinitif)) = Application.Transpose(arrVariableTableauDefinitif)
End With

 

[Etxezarreta]

Merci beaucoup, j'avais effectivement mon array en ligne et non en colonne.
Bonne soirée!
Etxe.

 

[job75]

Bonsoir Etxezarreta, Patrice33740,

S'agissant de créer une liste sans doublon l'objet Dictionary s'impose :

Sub CreationListeUniqueDeBinomeCouleur_Forme()
Dim tablo, d As Object, i&
tablo = wksDonnees.[A1].CurrentRegion.Resize(, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tablo): d(tablo(i, 2)) = "": Next
With wksResultat
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    If d.Count Then .[A1].Resize(d.Count) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
    .Range("A" & d.Count + 1 & ":A" & .Rows.Count).ClearContents 'RAZ en dessous
    With .UsedRange: End With 'actualise la barre de défilement verticale
    .Activate 'facultatif
End With
End Sub

A+

 

[BOISGONTIER]

Bonsoir,


http://boisgontierjacques.free.fr/pages_site/Doublons.htm#SupDoubBD

Boisgontier

 

[mapomme]

Bonjour à tous,

Sinon, pour le fun, on peut le faire avec les fonctions Excel.

Sub Test()
  With wksResultat
    .Activate: Application.ScreenUpdating = False
    .Range("a:a").Clear
    wksDonnees.Range("tabDonnees[Concatenr Couleur-Forme]").Copy
    .Range("a1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.RemoveDuplicates Columns:=1, Header:=xlNo
    Application.Goto .Range("a1"), True
  End With
End Sub

 

[Dranreb]

Bonjour.
Ça ne vaut peut être pas le coup de l'installer juste pour ça, mais si on a déjà, pour d'autres usages, mon module de service MSujetCBx ça peut s'écrire en peu d'instructions :

Sub Test()
Dim S
S = SujetCBx([tabDonnees[Concatenr Couleur-Forme]])
wksResultat.[A1:A500].ClearContents
wksResultat.[A1].Resize(UBound(S(0)) + 1).Value = WorksheetFunction.Transpose(S(0))
End Sub

Pour la petit histoire, l'élément S(1) contiendrait en plus la liste des tables de numéros de lignes dans tabDonnees contennant la valeur correspondante dans S(0)