MACRO COMPTEUR DOUBLON + ECRITURE

Y compris Power BI, Power Query et toute autre question en lien avec Excel
Répondre
m
minautoretitan
Nouveau venu
Nouveau venu
Messages : 6
Inscrit le : 21 septembre 2016
Version d'Excel : Office 2010

Message par minautoretitan » 21 septembre 2016, 11:53

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
DOUBLONS.xls
(105 Kio) Téléchargé 20 fois
p
patrick1957
Passionné d'Excel
Passionné d'Excel
Messages : 3'121
Appréciations reçues : 33
Inscrit le : 24 août 2015
Version d'Excel : 2007-2010-2016 PC

Message par patrick1957 » 21 septembre 2016, 12:40

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.
Je fais du géocaching et vous ?
Indentez vos codes VBA, ---> http://www.oaltd.co.uk/Indenter/Default.htm
A lire pour les débutants: http://www.xlerateur.com/divers/2010/05 ... nnees-612/
Répondre
  • Sujets similaires
    Réponses
    Vues
    Dernier message