Surbrillance de lignes avec doublons dans une colo. précise

Bonjour,

Je viens ici de temps en temps glaner quelques infos quand je bloque sur un truc, car mes connaissances excel sont plutôt limitées (plus un passe temps qu'autre chose !!).

Et justement, j'ai un soucis pour mettre en surbrillance des lignes comportant des doublons sur une colonne (ref) de plusieurs feuilles; je m'explique:

-1 classeur comportant des données de la feuille(2) à la feuille(x) avec x colonnes de données.

-Dans chacune de ces feuilles chaque cellule de la colonne D doit être unique (si elle existe en D1 de la feuille(2) et en D1351 de la feuille(x), je voudrais que la ligne 1 de la feuille 1 soit mise en surbrillance, ainsi que la ligne 1351 de la feuille(x))....mais, rien n'empêche d'avoir des doublons dans les colonnes (A,B,C,E,F)...

Je connais "la mise en forme conditionelle", mais celle ci n'est pas adaptable à ma demande; donc seule possibilité reste un code Vba dans un module que j'exécute; mais comme mes connaissances en Vba sont plutôt limitées, sauf à enregistrer une macro,...

Je remercie donc d'avance celui ou ceux qui pourraient me donner une solution au problème exposé.

(feuille d'exemple jointe)

Bonne fin de week-end.

bonjour,

une proposition

Sub aargh()
    For i1 = 1 To Sheets.Count - 1
    Set c = Sheets(i1)
        If c.Name <> "feuil1" Then 'ignorer feuil1
            For i2 = i1 + 1 To Sheets.Count
            Set c1 = Sheets(i2)
                If c1.Name <> "feuil1" And c1.Name <> c.Name Then
                    dl = c.Cells(Rows.Count, 4).End(xlUp).Row
                    dl1 = c1.Cells(Rows.Count, 4).End(xlUp).Row
                    Set pl = c1.Range("D1:D" & dl1)
                    For i = 1 To dl
                        If c.Cells(i, 4) <> "" Then
                            Set re = pl.Find(c.Cells(i, 4), lookat:=xlWhole)
                            If Not re Is Nothing Then
                                fa = re.Address
                                Do
                                    re.EntireRow.Interior.Color = vbYellow
                                    c.Rows(i).Interior.Color = vbYellow
                                    Set re = pl.FindNext(re)
                                Loop Until re Is Nothing Or re.Address = fa
                            End If
                        End If
                    Next i
                End If
            Next i2
        End If
    Next i1
End Sub

Merci,

C'est ce que je cherchais, et demandé; mais néanmoins, je viens de m'apercevoir, car j'ai omis de préciser un chose importante:

-si je supprime les lignes en double (sauf sur une des feuilles, afin pour redevenir unique), la surbrillance devrait disparaître.

jean luc

Bonjour,

une adaptation du code

Sub aargh()
    For Each c In Sheets
        c.Cells.Interior.Color = vbWhite
    Next c
    For i1 = 1 To Sheets.Count - 1
        Set c = Sheets(i1)
        If c.Name <> "feuil1" Then    'ignorer feuil1
            For i2 = i1 + 1 To Sheets.Count
                Set c1 = Sheets(i2)
                If c1.Name <> "feuil1" And c1.Name <> c.Name Then
                    dl = c.Cells(Rows.Count, 4).End(xlUp).Row
                    dl1 = c1.Cells(Rows.Count, 4).End(xlUp).Row
                    Set pl = c1.Range("D1:D" & dl1)
                    For i = 1 To dl
                        If c.Cells(i, 4) <> "" Then
                            Set re = pl.Find(c.Cells(i, 4), lookat:=xlWhole)
                            If Not re Is Nothing Then
                                fa = re.Address
                                Do
                                    re.EntireRow.Interior.Color = vbYellow
                                    c.Rows(i).Interior.Color = vbYellow
                                    Set re = pl.FindNext(re)
                                Loop Until re Is Nothing Or re.Address = fa
                            End If
                        End If
                    Next i
                End If
            Next i2
        End If
    Next i1
End Sub

Bonjour à tous,

une autre possibilité,

Sub test()
For Each f In Worksheets
 If f.Name <> "Feuil1" Then
   For Each c In f.Range("D1:D" & f.Cells(Rows.Count, 4).End(xlUp).Row)
     For Each Sh In Worksheets
       t1 = Sh.Name
       If Sh.Name <> "Feuil1" Then n = n + Application.CountIf(Sh.Range("D:D"), c)
     Next
     If n > 1 Then
      f.Rows(c.Row).Interior.Color = RGB(0, 255, 0)
     End If
     n = 0
  Next
 End If
Next
End Sub

edit: j'ai ajouté une macro événementielle "Calcutate" pour enlever la couleur au cas ou,

Bonsoir,

Merci à vous deux, ça fonctionne comme je désirais (les 2 méthodes fonctionnent).

Je coche résolu.

A+++