Mettre les formats de police et fond de cellule

[isa44]

Bonjour , j'ai cette fonction à améliorer :

Sur la valeur trouvée il faudrait appliquer les formats de police et fond de cellule.

Function ChercheTrain(sVal As String)
  Dim Rng As Range, CelF As Range
  Set Rng = Range("H:H,P:P,X:X,AF:AF")
  Application.Volatile
  'On Error Resume Next
  Set CelF = Rng.Find(What:=sVal, LookIn:=xlValues, LookAt:=xlWhole, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
  ' si une valeur est trouvée
  If Not CelF Is Nothing Then
    ChercheTrain = CelF.Offset(0, -6).Value
    ' Mettre la valeur ainsi que ses formats police et fond de cellule
    
        If CelF.Offset(0, -5).Value = "" Then ChercheTrain = ""
  End If

End Function

Merci pour votre aide

 

[JBARBE]

Re : Mettre les formats de police et fond de cellule

Bonjour à tous,

Peut-être ceci !

If CelF.Offset(0, -5).Value = "" Then ChercheTrain.Interior.ColorIndex=3 ' interieur rouge
If CelF.Offset(0, -5).Value = "" Then ChercheTrain.Font.ColorIndex=6 'texte jaune

bonne journée

 

[isa44]

Re : Mettre les formats de police et fond de cellule

Ce n'est pas exactement cela :

ChercheTrain = CelF.Offset(0, -6).Value
    ' Mettre la valeur ainsi que ses formats police et fond de cellule

Sur la valeur trouvée du " ChercheTrain " je voudrais appliquer les formats tels qu'ils sont de cette valeur : taille et couleur de la police ainsi que le format de fond de cellule.

 

[Dranreb]

Re : Mettre les formats de police et fond de cellule

Bonjour.
Une fonction utilisée dans une cellule ne peut pas renvoyer à Excel autre chose qu'une valeur pour cette cellule.
Elle pourrait tout au plus en plus ajouter à une collection une consigne qui serait analysée par une Worksheet_Calculate.
Mais il y aurait des essais à faire !

 

[isa44]

Re : Mettre les formats de police et fond de cellule

Bonjour , je ne savais pas.

Voici un exemple du résultat attendu dans le fichier joint.

 

[Dranreb]

Re : Mettre les formats de police et fond de cellule

Bonjour.

Ça, dans le module "Feuil11 (Remisage)" à l'air pas mal :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim CelF As Range
If Target.Count <> 1 Then Exit Sub
If IsEmpty(Target.Value) Then Exit Sub
Set CelF = Me.[B:B,J:J,R:R,Z:Z].Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole, _
   SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False)
If Not CelF Is Nothing Then CelF.Copy: Target.PasteSpecial Paste:=xlPasteAllExceptBorders
End Sub

Il y aurait un sérieux ménage à faire dans les noms dans le classeur !