XL 2013 Ajouter un caractère à un doublon VBA

[broyal579]

Bonjour à tous,

Nouveau sur le forum, j'ai un projet à effectuer avec du VBA... Etant débutant ce fut assez long mais je m'en suis sorti...

J'ai un dernier problème que je n'arrive pas à résoudre et je sollicite votre aide.

Je ne peux malheureusement pas joindre le fichier car cela concerne l'entreprise qui m'accueille en stage donc je vais essayer quand même essayer d'être précis

Nous avons un fichier qui permet un suivi de dossiers et certains dossiers peuvent avoir le même ID... Les ID sont placés dans la colonne A. Je souhaiterais que si deux dossiers ont un ID identique, un des deux se voit ajouter un caractère comme une étoile, en gros j'aimerais que cela ressemble à cela. Les ID sont ajoutés dans la feuille via un UserForm qui permet d'entrer toutes les informations relatives aux dossiers.

51521 51521
23645 23645
51521 -> 51521*

Je m'excuse d'avance si ce n'est pas très clair, n'hésitez pas si besoin de précision...

Grand merci d'avance!

 

[JM27]

Bonjour
es espérant qu'il n'y ait pas de triplon

 

[broyal579]

Bonjour, merci pour le fichier mais c'est la preuve que je n'ai pas été précis dans ma demande '

En fait, je pense qu'une macro qui se lancerait avec un bouton me suffirait. Il faudrait que cette macro ajoute une * au doublon de la colonne A... mais bon je ne vois pas trop comment faire cela...

Merci pour votre aide en tout cas

 

[mapomme]

Bonjour à tous,

Une autre version :

Sub doublons()
Dim t, d, i&, x
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      t = .Cells(1, "a").Resize(.Cells(.Rows.Count, "a").End(xlUp).Row)
      Set d = CreateObject("scripting.dictionary")
      For i = 1 To UBound(t)
         x = Replace(t(i, 1), "*", "")
         If Not d.exists(x) Then d.Add x, "" Else t(i, 1) = x & "*"
      Next i
      .Cells(1, "a").Resize(ubound(t)) = t
   End With
End Sub

 

[broyal579]

Ca fonctionne parfaitement !!!

Merci @mapomme

et encore merci à @JM27 pour avoir essayer de m'aider !

Bonne journée à vous

 

[JM27]

bonjour
Salut ma Pomme
@broyal579
Il suffisait d'adapter ma solution à ton fichier

Sub Afficher()
    Dim Cell As Range
    Dim Collec As New Collection
    With Sheets("Feuil1")
            For Each Cell In .Range("A1:A" & .Range("A65536").End(xlUp).Row)
                On Error Resume Next
                    Collec.Add Cell, CStr(Cell)
                    If Err <> 0 Then
                        Cell.Value = Cell & " *"
                        Err = 0
                    End If
                On Error GoTo 0
            Next
    End With
End Sub

 

[broyal579]

Ca fonctionne aussi merci @JM27

 

[patricktoulon]

bonsoir
celle de @mapomme est mieux elle prévoit plus de deux jumeaux
cela dit avec la collection tu peux faire pareil

Sub Afficher()
    Dim Cell As Range
    Dim Collec As New Collection
    With Sheets("Feuil1")
            For Each Cell In .Range("A1:A" & .Range("A65536").End(xlUp).Row)
                On Error Resume Next
                    Collec.Add replace(Cell,"*",""), CStr(replace(Cell,"*",""))
                    If Err <> 0 Then
                        Cell.Value = Cell & " *"
                        Err = 0
                    End If
                On Error GoTo 0
            Next
    End With
End Sub

 

[JM27]

bonjour
Voir le #2 .
Si il y a un triplon , cela ne fonctionne pas non plus.
Avec la version de patrick , si tu as un triplon , tu le transformes en doublon avec l'étoile.
ci joint une solution capillo-tractée

 

[broyal579]

Merci @JM27 c'est encore mieux car il y a effectivement possibilité de Triplon dans mon fichier

 

[patricktoulon]

re
bonjour
bien vu la 2d passe @JM27

Avec la version de patrick , si tu as un triplon , tu le transformes en doublon avec l'étoile.

là je pige pas
l’intérêt c'est de les pointer ; si il y a moins une l’étoile c'est que c'est un doublons ou triplion et/ou plus

mais j’apprécie quand même l'astuce de la 2d passe

par contre si on décidait de travailler sur une variable tableaux en cas de grande plage (pour accélérer le procc) là ça déraille complètement ça fait pas le job et la 2d passe déclenche une insuffisance de mémoire

Sub Afficher()
    Static TbL
    Dim plage As Range, Collec As New Collection, NbErreur As Byte, I&
    Set plage = [Feuil1!A1].Resize([Feuil1!A65535].End(xlUp).Row)
      TbL = plage.Value
            For I = 1 To UBound(TbL)
                On Error Resume Next
                    Collec.Add CStr(TbL(I)), CStr(TbL(I))
                    If Err <> 0 Then
                        TbL(I) = TbL(I) & " *"
                        Err.Clear
                        NbErreur = NbErreur + 1
                    End If
                On Error GoTo 0
            Next
    plage.Value = TbL'mise a jour le 1 ere passe
    'If NbErreur > 0 Then'déclenche une insuffisance de memoire
       ' Afficher
    'End If
[Feuil1!B1].Resize(UBound(TbL)) = TbL

End Sub

 

[mapomme]

Re,
On peut aussi indexer les doublons.

Sub NumDoublons()
Dim t, d, i&, x, n&
   With ActiveSheet
      If .FilterMode Then .ShowAllData
      t = .Cells(1, "a").Resize(.Cells(.Rows.Count, "a").End(xlUp).Row)
      Set d = CreateObject("scripting.dictionary")
      For i = 1 To UBound(t)
         t(i, 1) = Trim(t(i, 1))
         n = InStr(t(i, 1), " (")
         If n > 0 Then t(i, 1) = Trim(Left(t(i, 1), n - 1))
         If Not d.exists(t(i, 1)) Then
            d.Add t(i, 1), 1
         Else
            n = d(t(i, 1)) + 1: d(t(i, 1)) = n
            t(i, 1) = t(i, 1) & " *" & Space(3 - Len(CStr(n))) & n
         End If
      Next i
      .Cells(1, "a").Resize(UBound(t)) = t
   End With
End Sub