INSCRIRE NOM

[REDGS]

Bonjour,
Dans mon programme colonne A, je voudrais inscrire qu'une seule fois un nom qui lui est plusieurs fois dans la colonne D.
Merci de m'aider, cordialement
Redgs

 

[Lone-wolf]

Bonjour REDGS

Un fichier joint, ça nous aiderait aussi. Sinon pas d'aide possible.

 

[REDGS]

Bonjour REDGS

Un fichier joint, ça nous aiderait aussi. Sinon pas d'aide possible.

exemple ci-joint

 

[Lone-wolf]

Re

Un à la fois comme d'écrit dans le fichier, sais pas faire. Si en une fois la colonne sans doublons oui.

 

[JHA]

Bonjour à tous,

A essayer, formule matricielle

=SIERREUR(INDEX($E$1:$E$100;EQUIV(0;INDEX(NB.SI($A$1:$A1;$E$1:$E$100););0));"")

Valider par Ctrl+Maj+Entrée

JHA

 

[job75]

Bonjour REDGS, Lone-wolf, JHA,

La question n'est pas très claire mais voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, resu(), d As Object, n&, i&
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
t = Range("E1", Range("E" & Rows.Count).End(xlUp)(2)) 'tableau, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(t) + 1, 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
d("NOMS") = "": resu(1, 1) = "NOMS": n = 1
For i = 1 To UBound(t)
    If t(i, 1) <> "" And Not d.exists(t(i, 1)) Then
        d(t(i, 1)) = ""
        n = n + 1
        resu(n, 1) = t(i, 1)
    End If
Next
[A1].Resize(n) = resu
Range("A" & n + 1 & ":A" & Rows.Count).ClearContents 'RAZ en dessous
Application.EnableEvents = True 'réactive les évènements
End Sub

La macro se déclenche quand on modifie une cellule.

Edit : On Error Resume Next peut être supprimé ici.

A+

 

[Lone-wolf]

Bonsoir job75, JHA

 

[job75]

Re,

L'intérêt du VBA c'est qu"on peut facilement compléter le code, par exemple ici pour ignorer la casse et trier :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim t, resu(), d As Object, n&, i&
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
t = Range("E1", Range("E" & Rows.Count).End(xlUp)(2)) 'tableau, plus rapide, au moins 2 éléments
ReDim resu(1 To UBound(t) + 1, 1 To 1)
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
d("NOMS") = "": resu(1, 1) = "NOMS": n = 1
For i = 1 To UBound(t)
    If t(i, 1) <> "" And Not d.exists(t(i, 1)) Then
        d(t(i, 1)) = ""
        n = n + 1
        resu(n, 1) = Application.Proper(t(i, 1)) 'nom propre
    End If
Next
[A:A].ClearContents
[A1].Resize(n) = resu
[A1].Resize(n).Sort [A1], xlAscending, Header:=xlYes 'tri alphabétique
Application.EnableEvents = True 'réactive les évènements
End Sub

Fichier (2).

Edit : On Error Resume Next peut être supprimé ici.

A+

 

[mapomme]

Bonsoir à tous,

Un autre essai basé sur des formules et instructions Excel (donc un peu moins rapide que le code de @job75 ) :

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Target, Columns(5)) Is Nothing Then
      Application.ScreenUpdating = False
      Worksheets("Feuil1").Activate
      Columns(1).Clear: On Error Resume Next
      With Range("a1:a" & Cells(Rows.Count, "e").End(xlUp).Row)
         .FormulaR1C1 = "=IF(RC[4]="""",NA(),TRIM(PROPER(RC[4])))": .Value = .Value
      End With
      Cells(1, 1).Insert xlShiftDown: Cells(1, 1) = "NOMS"
      With Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row)
         .Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes
         .RemoveDuplicates 1, xlNo
         .SpecialCells(xlCellTypeConstants, xlErrors).Delete xlShiftUp
      End With
      Range("a1:a" & Cells(Rows.Count, "a").End(xlUp).Row).Borders.LineStyle = xlContinuous
   End If
End Sub

 

[job75]

Bonjour mapomme, le forum,

Le code de mon fichier (2) post #8 s'exécute chez moi en 4,6 millisecondes.

Le tien post #9 s'exécute en 4,4 millisecondes.

Et même en 3,3 millisecondes en simplifiant la formule :

   .FormulaR1C1 = "=TRIM(PROPER(RC[4]))": .Value = .Value

et en supprimant :

        .SpecialCells(xlCellTypeConstants, xlErrors).Delete xlShiftUp

Bonne journée.

 

[mapomme]

Bonjour @job75 ,

Merci pour tes propositions d'améliorations et tes tests.

Très bon week-end.

Voir version V1a avec intégration des remarques de job75.

 

[job75]

Re,

Notez que la simple création du Dictionary prend du temps (un peu plus de 1 milliseconde).

Cette méthode est quand même la plus rapide sur de grands tableaux.

Sur les derniers fichiers copiez la plage D1:E18 sur D1:E54000 :

- fichier du post #8 => 0,14 seconde

- fichier du post #11 => 0,73 seconde.

A+