XL 2019 Suppression automatique de cellules

Yacine

XLDnaute Occasionnel
Bonjour tout le monde,

Je voudrais obtenir une colonne (Colonne 3) en supprimant les cellules identiques des colonnes 1 et 2 comme sur le fichier joint.

Merci par avance
 

Pièces jointes

  • Exemple.xlsx
    10.4 KB · Affichages: 10

job75

XLDnaute Barbatruc
Bonjour Yacine, Jacky67, le forum,

Si le tableau est très grand, pour aller vite, il faut des tableaux VBA et le Dictionary :
VB:
Sub Liste_Col3()
Dim d As Object, tablo, j%, i&, x$, a, b, n&
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
tablo = [B1].CurrentRegion.Columns(1).Resize(, 2) 'matrice, plus rapide
For j = 1 To 2
    For i = 2 To UBound(tablo)
        x = tablo(i, j)
        If x <> "" Then d(x) = d(x) + 1 'comptage
Next i, j
'---tableau des résultats---
If d.Count Then
    ReDim resu(1 To d.Count, 1 To 1)
    a = d.keys: b = d.items
    For i = 0 To UBound(a)
        If b(i) < 2 Then n = n + 1: resu(n, 1) = a(i)
    Next i
End If
'---restitution---
With ActiveSheet 'à adapter éventuellement
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    With .[D2] '1ère cellule de destination
        If n Then .Resize(n) = resu
        .Offset(n).Resize(Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
    End With
    With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
A+
 

Pièces jointes

  • Exemple(1).xlsm
    19.9 KB · Affichages: 4

Discussions similaires

Statistiques des forums

Discussions
312 163
Messages
2 085 860
Membres
103 006
dernier inscrit
blkevin