Ligne doublon VBA

bonsoir,

une fois n'est pas coutume je demande de l'aide

je désirerais une macro de doublon macro qui mettent les lignes STRICTEMENT identique en couleur.

je ne souhaite pas de MFC , il me le faut par macro

j'ai essayer d'en adapter une que j'avais en stock , mais je plante.

merci de votre aide

cordialement

Salut Yoda,

Un essai à tester :

Option Explicit

Sub yy()
Dim i As Integer, Index_Couleur As Integer
Dim Première_Ligne As Integer, Dernière_Ligne As Integer

Application.ScreenUpdating = False
Index_Couleur = 3

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    Range("I" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i) & Range("D" & i) & Range("E" & i) & Range("F" & i) & Range("G" & i) & Range("H" & i)
    Range("J" & i) = i
Next i

Range("A1:J" & i - 1).Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlNo

Range("I1").Activate

Retour:

Première_Ligne = ActiveCell.Row

Do Until ActiveCell.Offset(1, 0) <> ActiveCell
    If ActiveCell = "" Then GoTo Etiquette
    ActiveCell.Offset(1, 0).Activate
Loop

Dernière_Ligne = ActiveCell.Row

If Dernière_Ligne <> Première_Ligne Then Range("A" & Première_Ligne & ":H" & Dernière_Ligne).Interior.ColorIndex = Index_Couleur

ActiveCell.Offset(1, 0).Activate

Index_Couleur = Index_Couleur + 1

GoTo Retour

Etiquette:
Range("A1:J" & i - 1).Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlNo
Range("I:J").ClearContents

End Sub

Cordialement.

parfait Yvouille !

j'ai juste modifier pour n'avoir qu'une seul couleur , merci de ton aide

Sub essai2()

Dim i As Integer, Index_Couleur As Integer

Dim Première_Ligne As Integer, Dernière_Ligne As Integer

Application.ScreenUpdating = False

'Index_Couleur = 1

For i = 1 To Range("A" & Rows.Count).End(xlUp).Row

Range("I" & i) = Range("A" & i) & Range("B" & i) & Range("C" & i) & Range("D" & i) & Range("E" & i) & Range("F" & i) & Range("G" & i) & Range("H" & i)

Range("J" & i) = i

Next i

Range("A1:J" & i - 1).Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlNo

Range("I1").Activate

Retour:

Première_Ligne = ActiveCell.Row

Do Until ActiveCell.Offset(1, 0) <> ActiveCell

If ActiveCell = "" Then GoTo Etiquette

ActiveCell.Offset(1, 0).Activate

Loop

Dernière_Ligne = ActiveCell.Row

If Dernière_Ligne <> Première_Ligne Then Range("A" & Première_Ligne & ":H" & Dernière_Ligne).Interior.ColorIndex = 4 'Index_Couleur

ActiveCell.Offset(1, 0).Activate

'Index_Couleur = Index_Couleur + 1

GoTo Retour

Etiquette:

Range("A1:J" & i - 1).Sort Key1:=Range("J1"), Order1:=xlAscending, Header:=xlNo

Range("I:J").ClearContents

End Sub

merci encore

cordialement