Tri enlever doublons et numéroter

erics83

XLDnaute Impliqué
Bonjour,

Je pense que c'est très simple, mais....je n'y arrive pas.....j'ai regardé les excellents tutos de JB sur les doublons, donc, je vois comment identifier, supprimer, lister, etc..les doublons....
Mon souci est encore plus simple :
je souhaiterai juste lister sans doublons et numéroter ....comme j'ai toujours un problème pour être clair dans mes explications..j'ai fait une petite simulation...lol....:

upload_2019-1-18_20-0-33.png


Merci pour votre aide,
 

JHA

XLDnaute Barbatruc
Bonjour à tous,

Je pense que personne n'a envie de recopier ton tableau, si tu mets un fichier exemple, tu auras certainement plus de réponse.
En attendant, un essai avec ce que j'ai compris.

JHA
 

Pièces jointes

  • Supprimer doublons et ID.xlsx
    46.9 KB · Affichages: 13

erics83

XLDnaute Impliqué
Merci JHA,

Effectivement avec un fichier en PJ, c'est mieux.....;)

Merci pour votre "essai" (réussi !). En fait je souhaitais réaliser cette "opération" via un code VBA, car là, c'est juste quelques lignes, mais dans mon projet, j'en ai nettement plus et avec plusieurs colonnes, dans plusieurs feuilles.....

Merci pour votre aide,
 

Pièces jointes

  • test doublon ID.xlsx
    10.7 KB · Affichages: 8
Dernière édition:

Dranreb

XLDnaute Barbatruc
Bonjour.
Facile avec ma fonction Gigogne du projet GigIdx à mettre en référence, défini en complément xlam dont je joint le classeur précurseur.
VB:
Sub Regrouper()
Dim Nom As SsGr, Prénom As SsGr, NNom&, NPré&, L&, TR(1 To 500, 1 To 3)
For Each Nom In Gigogne(Feuil1.[A2:B2], 1, 2)
   NNom = NNom + 1: NPré = 0
   For Each Prénom In Nom.Co
      NPré = NPré + 1
      L = L + 1
      TR(L, 1) = "'" & NNom & "." & NPré
      TR(L, 2) = Nom.Id
      TR(L, 3) = Prénom.Id
      Next Prénom, Nom
Feuil1.[D2:F2].Resize(UBound(TR, 1)).Value = TR
End Sub
 

Pièces jointes

  • GigIdx.xlsm
    63.5 KB · Affichages: 20

erics83

XLDnaute Impliqué
Merci pour votre réponse Dranreb,

Je dois faire une mauvaise manipulation, car ....cela ne fonctionne pas.....j'ai essayé aussi en enlevant les références Ssgr :
Code:
Sub Regrouper()
'Dim Nom As SsGr, Prénom As SsGr, NNom&, NPré&, L&, TR(1 To 500, 1 To 3)
Dim NNom&, NPré&, L&, TR(1 To 500, 1 To 3)
'For Each Nom In Gigogne(Feuil1.[A2:B2], 1, 2)
For Each Nom In Feuil2.[E2:F50]
   NNom = NNom + 1: NPré = 0
   For Each Prénom In Nom
      NPré = NPré + 1
      L = L + 1
      TR(L, 1) = "'" & NNom & "." & NPré
      TR(L, 2) = Nom.ID
      TR(L, 3) = Prénom.ID
      Next Prénom, Nom
Feuil3.[D2:F2].Resize(UBound(TR, 1)).Value = TR
End Sub
mais cela ne fonctionne pas non plus.....

Merci pour votre aide,
 

erics83

XLDnaute Impliqué
re-bonjour,

A force d'étudier le code de Dranreb, j'ai essayé d'utiliser la logique....pas très "orthodoxe", mais cela fonctionne.... :
Code:
Sub eric()
Dim i As Integer
Dim a As Integer
Dim b As Integer

b = 1
a = 0
For i = 2 To Feuil2.Range("E65536").End(xlUp).Row
nb = nb + 1
If Feuil2.Cells(i, 5) = Feuil2.Cells(i - 1, 5) Then
b = b + 1
Else
a = a + 1
b = 1
End If
Feuil3.Cells(nb, 1).NumberFormat = "@" ' Format Texte
Feuil3.Cells(nb, 1) = a & "." & b
Next

End Sub

Et si une âme charitable souhaite améliorer et/ou corriger ce code afin qu'il corresponde bien à un code VBA, ce serait très volontiers, ainsi je pourrais corriger mes erreurs à l'avenir....

Merci pour votre aide,
 

job75

XLDnaute Barbatruc
Bonour erics83, JHA, Bernard,

Voyez le fichier joint et cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
Code:
Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal target As Range)
Dim tablo, d As Object, i As Long, num() As String, x As String, p As Byte
tablo = [A1].CurrentRegion.Resize(, 2) 'matrice, plus rapide
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 2 To UBound(tablo): d(tablo(i, 1) & Chr(1) & tablo(i, 2)) = "": Next
Application.ScreenUpdating = False
Application.EnableEvents = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [D2] '1ère cellule à adapter
    .Resize(Rows.Count - 1, 3).ClearContents 'RAZ
    If d.Count Then
        With .Cells(1, 2).Resize(d.Count)
            .Value = Application.Transpose(d.keys) 'Transpose limitée à 65536 lignes
            .TextToColumns .Cells(1), xlDelimited, Other:=True, OtherChar:=Chr(1) 'commande Convertir
            .Resize(, 2).Sort .Columns(1), xlAscending, .Columns(2), , xlAscending, Header:=xlNo 'tri alphabétique
            tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
            ReDim num(1 To UBound(tablo), 1 To 1)
            num(1, 1) = "1.1"
            For i = 1 To UBound(tablo) - 1
                x = num(i, 1): p = InStr(x, ".")
                If tablo(i + 1, 1) = tablo(i, 1) Then
                    num(i + 1, 1) = Left(x, p) & Mid(x, p + 1) + 1
                Else
                    num(i + 1, 1) = Val(Left(x, p)) + 1 & ".1"
                End If
            Next
            .Columns(0) = num
        End With
    End If
End With
Application.EnableEvents = True
End Sub
Elle se déclenche quand on modifie ou valide une cellule quelconque.

A+
 

Pièces jointes

  • test doublon ID(1).xlsm
    28.9 KB · Affichages: 20
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 711
Messages
2 081 783
Membres
101 817
dernier inscrit
carvajal