Bonsoir à tous,
J'ai récupéré une petite macro sur le site, le seul bémol est que la macro s'effectue uniquement sur une feuille nommée Exemple, je souhaiterais qu'elle fonctionne sur n'importe quelle feuille peu importe son nom.
Par avance, Merci beaucoup!
Pol.
Sub ColorerDoublonsCrébit()
Dim plage As Range
Dim Cel As Range, Celbis As Range
Dim L As Integer, lig As Integer, N As Byte
Application.ScreenUpdating = False
With Sheets("Exemple")
L = .Range("G65000").End(xlUp).Row
'effacement des couleurs
Set plage = .Range("G1:G" & L)
plage.Interior.ColorIndex = xlNone
'Coloration des doublons
N = 2
For Each Cel In plage
lig = Cel.Row
If Application.CountIf(plage, Cel) > 1 And Cel.Interior.ColorIndex = xlNone Then
If N < 56 Then
N = N + 1
Else
N = 3
End If
Cel.Interior.ColorIndex = N
For Each Celbis In plage
If Celbis = Cel And Celbis.Row <> Cel.Row And Celbis.Interior.ColorIndex = xlNone Then
Celbis.Interior.ColorIndex = Cel.Interior.ColorIndex
End If
Next Celbis
End If
Next Cel
Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub
J'ai récupéré une petite macro sur le site, le seul bémol est que la macro s'effectue uniquement sur une feuille nommée Exemple, je souhaiterais qu'elle fonctionne sur n'importe quelle feuille peu importe son nom.
Par avance, Merci beaucoup!
Pol.
Sub ColorerDoublonsCrébit()
Dim plage As Range
Dim Cel As Range, Celbis As Range
Dim L As Integer, lig As Integer, N As Byte
Application.ScreenUpdating = False
With Sheets("Exemple")
L = .Range("G65000").End(xlUp).Row
'effacement des couleurs
Set plage = .Range("G1:G" & L)
plage.Interior.ColorIndex = xlNone
'Coloration des doublons
N = 2
For Each Cel In plage
lig = Cel.Row
If Application.CountIf(plage, Cel) > 1 And Cel.Interior.ColorIndex = xlNone Then
If N < 56 Then
N = N + 1
Else
N = 3
End If
Cel.Interior.ColorIndex = N
For Each Celbis In plage
If Celbis = Cel And Celbis.Row <> Cel.Row And Celbis.Interior.ColorIndex = xlNone Then
Celbis.Interior.ColorIndex = Cel.Interior.ColorIndex
End If
Next Celbis
End If
Next Cel
Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub