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

Etxezarreta

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

Pièces jointes

  • EssaiArrBL.xlsm
    22.8 KB · Affichages: 19

job75

XLDnaute Barbatruc
Bonsoir Etxezarreta, Patrice33740,

S'agissant de créer une liste sans doublon l'objet Dictionary s'impose :
Code:
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+
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Sinon, pour le fun, on peut le faire avec les fonctions Excel.
Code:
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
 

Pièces jointes

  • Etxezarreta- EssaiArrBL- v1.xlsm
    21.4 KB · Affichages: 9

Dranreb

XLDnaute Barbatruc
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 :
VB:
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)
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
314 450
Messages
2 109 726
Membres
110 552
dernier inscrit
jasson