XL 2010 VBA : Boucle For each qui ne s'arrête pas

[Gllou06]

Bonjour à tous
Pour commencer, sachez que je ne suis pas un pro de la macro ni un habitué des forums mais voilà deux jours que je cherche une solution sur les sites sans trouver vraiment une réponse à mon problème !

Aujourd'hui, je tente de faire une boucle sur une colonne pour effacer les doublons en (conservant le premier) : tout se passe bien au niveau de l'action mais je dois faire une erreur puisque ma boucle "For each" ne s'arrête pas à la fin de ma liste. Quelqu'un peut-il me dire où est cette erreur ? (mon code -ci-joint- n'est peut-être pas "très propre" non plus... !).

A savoir : cette feuille ne sera pas visible par les utilisateurs (donc pas possible de passer par les filtres élaborés) c'est pourquoi je veux passer par une macro et, d'autre part je ne veux pas supprimer la ligne mais seulement effacer le contenu dupliqué. (Voir l'extrait joint).

Je suis preneur de toutes vos suggestions et vous remercie par avance.

 

[Robert]

Bonjour Gilou, bonjour le forum,

En fait, si j'ai bien compris, tu veux juste fusionner les cellules identiques de la colonne FAMILLE DE RISQUE. C'est ça ?

 

[JCGL]

Bonjour à tous,
Salut Robert (C'est toi...),

Pourquoi 2 boucles :
une For Each
une While... Wend

Peux-tu essayer :

Option Explicit

Sub Efface_Doublons()
Dim Derl&, Lig&
Derl = Feuil5.Range("G" & Rows.Count).End(xlUp).Row
    Range("E6:E" & Derl).Formula = "=COUNTIF(R6C6:RC[1],RC[1])"
For Lig = 6 To Derl
If Cells(Lig, "E") > 1 Then Cells(Lig, "F").ClearContents
Next Lig
Range("E6:E" & Derl) = ""
End Sub

A+ à tous

 

[ROGER2327]

Bonsoir à tous.

Et pourquoi pas, en supposant qu'il existe un onglet nommé «Feuil1», tout simplement :​

Sub EffaceDoublons()
Dim Cell As Range, donnée1 As String
    For Each Cell In Sheets("Feuil1").Range("F6:F" & Range("G1048576").End(xlUp).Row)
        If Cell.Value = donnée1 Then Cell.Clear Else donnée1 = Cell.Value
    Next
End Sub

Bonne nuit.

ℝOGER2327
#8496

Lundi 23 Gueules 144 (Occultation de Saint J. Torma, euphoriste - fête Suprême Quarte)
29 Pluviôse An CCXXV, 9,8566h - chélidoine
2017-W07-5T23:39:21Z

 

[ROGER2327]

Suite...

... si on veut la mise en forme :​

Sub EffaceDoublons()
Dim Plg As Range, Cell As Range, donnée1 As String, donnée2 As String
    With WorkSheets("Feuil1")
        Set Plg = .Range("F6:F" & .Range("G1048576").End(xlUp).Row)
        With Plg
            With .Resize(, 2)
                With .Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
                .VerticalAlignment = xlCenter
                .UnMerge
            End With
        End With
        For Each Cell In Plg
            If Cell.Value = donnée1 Then Cell.ClearContents Else donnée1 = Cell.Value
        Next
        For Each Cell In Plg
            If Cell.Value <> "" Then
                On Error Resume Next
                With .Range(.Range(donnée1), .Range(donnée2))
                    With .Resize(, 2).Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
                    .Merge
                End With
                On Error GoTo 0
                donnée1 = Cell.Address
            End If
            donnée2 = Cell.Address
        Next
        With .Range(.Range(donnée1), .Range(donnée2))
            With .Resize(, 2).Borders: .LineStyle = xlContinuous: .Item(xlInsideHorizontal).LineStyle = xlNone: End With
            .Merge
        End With
    End With
End Sub

ℝOGER2327
#8497

Mardi 24 Gueules 144 (Conversion de Saint Matorel, bateleur - fête Suprême Quarte)
30 Pluviôse An CCXXV, 0,4157h - traineau
2017-W07-6T00:59:52Z

 

[Gllou06]

Bonjour
Un grand merci JCLGL pour l'idée du comptage et à ROGER2327 qui m'enlève une épine du pied en proposant une solution complète.
Encore MERCI.
Bonne journée