Macro doublons qui se suivent

Bien le bonjour,

Communauté d'Excel-Pratique, je fais appel à vous car mon niveau en VBA est, on peut le dire, nul !

J'ai le besoin d'une macro, qui soit capable de compter les doublons d'une page, mais uniquement des doublons qui se suivent et d'inscrire ce nombre de doublon trouvé dans la bonne cellule...un petite illustration pour clarifier ma requête, simple à dire comme ça, mais peut-être pas simple à faire

Dans cet exemple, j'ai mis des "111111", mais ça peut très bien être autre chose, composé de chiffres et lettres

J'ai réussi jusqu'à présent à récupérer des macros par ci par là qui ont répondu à une partie de mes problèmes

J'ai une macro qui me trouvent tous les doublons d'une page et me les affichent dans une sorte de "pop-up" qui apparait, et pas seulement ceux qui se suivent

J'ai une macro qui me supprime tous les doublons, et pas seulement de supprimer ceux qui se suivent

Merci,

Bonjour,

Merci de préciser ce que tu veux faire exactement :

Compter les doublons qui se suivent ou supprimer les doublons qui se suivent.

Vba Obligatoire ou possibilité de formules ou autres.......

@+

Bonjour

une proposition.

Sub aargh()
    With Sheets("sheet1")    'nom de la feuille
        dl = .Cells(Rows.Count, "B").End(xlUp).Row
        vp = ""
        For i = 1 To dl + 1
            va = .Cells(i, 2)
            If va <> vp Then
                If vp <> "" Then
                    .Cells(fa, "D") = ctr
                End If
                fa = i
                ctr = 1
                vp = va
            Else
                ctr = ctr + 1
            End If
        Next i
        a = MsgBox("Supprimer les doublons", vbYesNo)
        If a = vbYes Then
            For i = dl To 1 Step -1
                If .Cells(i, "D") = "" And .Cells(i, "B") <> "" Then
                    .Rows(i).Delete shift:=xlUp
                End If
            Next i
        End If
    End With
End Sub

minautoretitan a écrit :

Doublons trouves.JPG

Bonjour à tous,

perso, je te déconseille de fusionner les cellules

P.

Alors là, top h2so4, pour mon exemple, j'ai réutilisé ta macro, cela fonctionne parfaitement

Je vais l'essayer dans mon application réelle, et je reviens vers vous

Je l'ai essayé dans mon application, ça fonctionne, les doublons sont bien trouvés et la quantités est bien inscrite dans la bonne cellule, les lignes doublons sont ensuite bien supprimés...

Mais, il peut y avoir une dernière contrainte que j'ai oublié de vous préciser, désolé...

Nous recevons un tableau avec plusieurs colonnes, la colonne avec "number", la colonne "quantity", et la colonne "repère"

Il faudrait qu'en plus que la macro trouve les doublons qui se suivent, inscrivent la quantité dans la bonne cellule, prennent en considération le "repère"

Dans l'exemple ci-dessous pour essayer d'illustrer, même si il y a disons 7 fois la ligne avec les "111111" qui sort, il faudrait qu'en fonction de si il y a un texte écris dans la colonne "repère", ça arrête de compter les doublons, écrit la quantité, et recommence à chercher les doublons...

Difficile d'expliquer

En espérant que vous aurez compris ma demande

Merci,

bonjour

procédure adaptée, Si tu as encore une demande merci de joindre ton classeur (exemple) plutôt qu'une photo.

Sub aargh()
    With Sheets("sheet1")    'nom de la feuille
        dl = .Cells(Rows.Count, "F").End(xlUp).Row
        vp = ""
        repp = ""
        For i = 4 To dl + 1
            va = .Cells(i, "F")
            repa = .Cells(i, "J")
            If va <> vp Or (va = vp And repa <> "" And repp <> repa) Then
                If vp <> "" Then
                    .Cells(fa, "H") = ctr
                End If
                fa = i
                ctr = 1
                vp = va
                repp = repa
            Else
                ctr = ctr + 1
            End If
        Next i
        a = MsgBox("Supprimer les doublons", vbYesNo)
        If a = vbYes Then
            For i = dl To 1 Step -1
                If .Cells(i, "H") = "" And .Cells(i, "F") <> "" Then
                    .Rows(i).Delete shift:=xlUp
                End If
            Next i
        End If
    End With
End Sub

Merci, tout fonctionne parfaitement, tu as réussi à me comprendre et résoudre mon problème, merci mille fois

Je clos le sujet

Bonsoir à tous,

Quelque chose doit m'échapper

Sub test1()
Dim dl As Long, rng As Range
    With Sheets("Feuil1")
        dl = .Cells(.Rows.Count, "F").End(xlUp).Row
        For Each rng In .Range("j5", .Range("j" & dl)).SpecialCells(xlCellTypeBlanks).Areas
            rng(0, -1).Value = rng.Rows.Count + 1
        Next
        .Range("j5", .Range("j" & dl)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

Vu le contexte cela doit suffire

klin89

Klin89 a écrit :

Bonsoir à tous,

Quelque chose doit m'échapper

Sub test1()
Dim dl As Long, rng As Range
    With Sheets("Feuil1")
        dl = .Cells(.Rows.Count, "F").End(xlUp).Row
        For Each rng In .Range("j5", .Range("j" & dl)).SpecialCells(xlCellTypeBlanks).Areas
            rng(0, -1).Value = rng.Rows.Count + 1
        Next
        .Range("j5", .Range("j" & dl)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

Vu le contexte cela doit suffire

klin89

Correct!

Effectivement, ça fonctionne aussi

Re minautoretitan,

Plus court

Sub test2()
Dim rng As Range
    With Sheets("Feuil1")
        For Each rng In .Range("f5", .Range("f" & Rows.Count).End(xlUp)).Offset(, 4).SpecialCells(xlCellTypeBlanks).Areas
            rng(0, -1).Value = rng.Cells.Count + 1
        Next
        .Range("f5", .Range("f" & Rows.Count).End(xlUp)).Offset(, 4).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End Sub

klin89