Bonjour Caninge,
Tu trouveras en pièce jointe une solution au problème posé.
Voici le code correspondant :
------------------------------------------------------------------------------------------------
Private Sub CommandButton1_Click()
'Paramétrage
ParSrcDeb = "B6" 'Première cellule de la colonne contenant les noms dans chaque feuille
ParTgtDeb = "C5" 'Première cellule de la colonne contenant les noms dans la feuille récap
ParMdlClr = "E5" 'Cellule à prendre comme modèle recherche pour couleurs fond et fonte
ParMdlClm = "G" 'Colonne à prendre comme modèle pour réinitialiser la Colonne résultat (peut être cachée)
Dim SrcDeb, SrcTbl, TgtDeb, TgtCur, TgtTbl, RefCol As Range
Set RefCol = Range(ParMdlClr)
Set TgtDeb = Range(ParTgtDeb)
Set TgtCur = TgtDeb
'Effacement de la précédente recherche et réinitialisation à partir du modèle de colonne résultat
Columns(ParMdlClm).Select
Selection.Copy
Columns(TgtDeb.Column).Select
ActiveSheet.Paste
'Analyse de toutes les feuilles sauf "Récap"
For Each Sht In ActiveWorkbook.Sheets
If Sht.Name <> "Récap" Then
Set SrcDeb = Range(ParSrcDeb)
'Set SrcDeb = Range(SrcDeb.Address & ":" & SrcDeb.End(xlDown).cells(
'Analyse des cellules, comparaison par rapport aux couleurs de référence, copie si identique
For Each Cel In Sht.UsedRange.Cells
If Cel.Column = SrcDeb.Column And Cel.Row >= SrcDeb.Row Then
If Cel.Value = "" Then Exit For
If Cel.Interior.Color = RefCol.Interior.Color And Cel.Font.Color = RefCol.Font.Color Then
TgtCur.Value = Cel.Value
TgtCur.Interior.Color = RefCol.Interior.Color
TgtCur.Font.Color = RefCol.Font.Color
Set TgtCur = TgtCur.Offset(1, 0)
End If
End If
Next Cel
End If
Next Sht
'Mise en forme des résultats si l'on a trouvé des cellules correspondant aux critères de recherche
If TgtCur.Address <> TgtDeb.Address Then
Set TgtTbl = Range(TgtDeb.Address & ":" & TgtCur.Offset(-1, 0).Address)
'Mise en forme des cellules au format de référence
RefCol.Select
Selection.Copy
TgtTbl.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Tri des résultats
TgtTbl.Sort Key1:=TgtDeb.Cells(1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Else
'Message à l'utilisateur si aucun résultat trouvé
MsgBox "Aucun nom répondant aux critères de couleurs n'a été trouvé"
End If
End Sub
------------------------------------------------------------------------------------------------
Je pense que la solution se comprend assez facilement mais s'il faut des explications complémentaires, recontacte moi.
Bon courage pour la suite ....
