Macro compteur doublon + ecriture

Bonjour,

Je suis assez novice en macro...j'essaye de trouver mon bonheur sur la toile, jusqu'à présent j'ai réussi...

Alors voilà, j'ai un Excel, avec deux colonnes, nom (chaine de caractère avec lettre/chiffre/symbole possible) et quantité (chiffre uniquement), plusieurs lignes avec des doublons de nom...je souhaiterai que ma macro comptabilise le nombre de ces doublons, l'écrive dans la première cellule de la ligne du doublon dans sa colonne quantité associé et supprime les ligne de doublons inutile....Vous avez suivi ahah ?

J'ai trouvé une macro permettant de comptabiliser ces doublons, mais il me les affichent seulement via une petite fenêtre, et moi je souhaiterai que ce nombre de doublons trouvés s'inscrivent directement dans la bonne colonne/ligne/cellule

Je vous joins un Excel, j'ai surligné en rouge les cellules où doivent par exemple s'inscrirent le nombre de doublons trouvés (pour cet exemple là car suivant l'Excel généré, les doublons peuvent être ailleurs)

Le code que j'ai troué :

Option Explicit
Option Base 1

Sub DOUBLONS()
    Dim Plage As Range
    Dim Tableau(), Resultat() As String
    Dim i As Integer, j As Integer, m As Integer
    Dim Un As Collection
    Dim DOUBLONS As String

    Set Un = New Collection
    'La plage de cellules (sur une colonne) à tester
    Set Plage = Range("A1:A" & Range("A65536").End(xlUp).Row)

    Tableau = Plage.Value

    On Error Resume Next
    'boucle sur la plage à tester
    For i = 1 To Plage.Count

        ReDim Preserve Resultat(2, m + 1)

        'Utilise une collection pour rechercher les doublons
        '(les collections n'acceptent que des données uniques)
        Un.Add Tableau(i, 1), CStr(Tableau(i, 1))

        'S'il y a une erreur (donc présence d'un doublon)
        If Err <> 0 Then

            'boucle sur le tableau des doublons pour vérifier s'il a déjà
            'été identifié
            For j = 1 To m + 1
                'Si oui, on  incrémente le compteur
                If Resultat(1, j) = Tableau(i, 1) Then
                    Resultat(2, j) = Resultat(2, j) + 1
                    Err.Clear
                    Exit For
                End If
            Next j

                'Si non, on ajoute le doublon dans le tableau
                If Err <> 0 Then
                    Resultat(1, m + 1) = Tableau(i, 1)
                    Resultat(2, m + 1) = 1

                    m = m + 1
                    Err.Clear

                End If
        End If
    Next i

    '----- Affiche la liste et le nombre de doublons --------
    For j = 1 To m
        DOUBLONS = DOUBLONS & Resultat(1, j) & " --> " & _
                    Resultat(2, j) & vbCrLf
    Next j

    MsgBox DOUBLONS

    Set Un = Nothing
End Sub

Pourriez-vous m'aider svp ?

Merci

Bonjour,

les collections (sauf sur mac) ont été délaissées au profit du dictionnaire

Essaye ceci

Sub ListeSansDoublons()
Set monDico = CreateObject("Scripting.Dictionary")
For Each c In Range("a1", [A65000].End(xlUp))
  If c <> "" Then
  monDico(c.Value) = monDico(c.Value) + 1
End If
Next c
[D2].Resize(monDico.Count, 1) = Application.Transpose(monDico.Keys)
[E2].Resize(monDico.Count, 1) = Application.Transpose(monDico.Items)
End Sub

P.