XL 2013 Ajouter un caractère à un doublon VBA

broyal579

XLDnaute Nouveau
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!
 
Solution
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

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

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Une autre version :
VB:
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
 
Dernière édition:

JM27

XLDnaute Barbatruc
bonjour
Salut ma Pomme ;)
@broyal579
Il suffisait d'adapter ma solution à ton fichier

VB:
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
 

patricktoulon

XLDnaute Barbatruc
bonsoir
celle de @mapomme est mieux elle prévoit plus de deux jumeaux
cela dit avec la collection tu peux faire pareil
VB:
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

XLDnaute Barbatruc
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
 

Pièces jointes

  • Classeur1.xlsm
    20.5 KB · Affichages: 6
Dernière édition:

patricktoulon

XLDnaute Barbatruc
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
VB:
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

XLDnaute Barbatruc
Supporter XLD
Re,
On peut aussi indexer les doublons.
VB:
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
 

Pièces jointes

  • broyal579- Indexer doublons- v1.xlsm
    17.6 KB · Affichages: 3
Dernière édition:

Discussions similaires

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
303 601
Messages
2 012 547
Membres
219 333
dernier inscrit
ludo719