Texte Définir les propriétés d'une cellule (couleurs, fonte, ..., valeur) dans une formule

Dudu2

XLDnaute Barbatruc
Ces fonctions personnalisées permettent de définir les propriétés d'une cellule ou d'une plage de cellules à partir d'une formule.

Ces fonctions s'utilisent par concaténation dans les formules.

Il y a 3 fonctions personnalisées:
  1. CallerProperties
    C'est celle qui sera le plus souvent utilisée dans une formule pour définir les propriétés de la cellule qui contient la formule.


    Exemple:
    = "Bonjour" & CallerProperties(HEXDEC("FF");HEXDEC("FFFF"))
    La cellule contenant la formule sera en caractères rouges ("FF") sur fond jaune ("FFFF").


    1714292598898.png


  2. RangeProperties
    Permet de définir les propriétés d'une plage de cellules désignée dans la formule qui n'est pas forcément liée à la cellule qui contient la formule.

    Exemple en A3: = "Couleurs en B3" & RangeProperties(B3;HEXDEC("FF");HEXDEC("FFFF"))
    La cellule B3 sera en caractères rouges ("FF") sur fond jaune ("FFFF").

    1714291793863.png


  3. CellValue
    Permet de définir la valeur d'une cellule désignée dans la formule qui n'est évidemment pas liée à la cellule qui contient la formule.

    Exemple en A2: = "Valeur en B2" & CellValue(B2;"Bonjour")
    La cellule B2 contiendra la valeur "Bonjour".

    1714291871275.png

Les fonctions CellValue et RangeProperties sont bien sûr combinables:
1714292412455.png


VB:
#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
    Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
    Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If
'
Private CallerCollection As New Collection
Private TimerId As Long

'--------------------------------------------------------------
'Propriétés de la cellule dont la formule concatène la fonction
'Exemple: ="Bonjour" & CallerProperties(HEXDEC("FF");HEXDEC("FFFF")) -> texte en rouge sur fond jaune sur la cellule "Caller"
'https://learn.microsoft.com/fr-fr/office/vba/language/reference/user-interface-help/color-constants
'--------------------------------------------------------------
Function CallerProperties(Optional ByVal FontColor As Long = xlNone, _
                          Optional ByVal InteriorColor As Long = xlNone, _
                          Optional ByVal FontName As Variant = xlNone, _
                          Optional ByVal FontSize As Double = xlNone, _
                          Optional ByVal FontBold As Variant = xlNone, _
                          Optional ByVal FontItalic As Variant = xlNone, _
                          Optional ByVal FontUnderline As Variant = xlNone, _
                          Optional ByVal FontStrikethrough As Variant = xlNone)
 
    RangeProperties Application.Caller, FontColor, InteriorColor, FontName, FontSize, FontBold, FontItalic, FontUnderline, FontStrikethrough
End Function

'----------------------------------------------------------------------
'Valeur d'une cellule quelconque dont une formule concatène la fonction
'Exemple en A2: ="Valeur en B2" & CellValue(B2;"Bonjour") -> Valeur "Bonjour" en B2
'----------------------------------------------------------------------
Function CellValue(ByVal Target As Range, _
                   ByVal Value As Variant)
   
    Dim TabCallerProperties(1 To 2) As Variant
 
    'Store the Value into a Table
    Set TabCallerProperties(1) = Target
    TabCallerProperties(2) = Value
 
    'Store the Table into a Collection
    CallerCollection.Add TabCallerProperties
 
    'Async run of the setting of the Properties
    If TimerId = 0 Then
        TimerId = SetTimer(0, 0, 100, AddressOf SetRangeProperties)
    End If
End Function
 
'------------------------------------------------------------------------
'Propriétés d'une plage quelconque dont une formule concatène la fonction
'Exemple en A3: = "Couleurs en B3" & RangeProperties(B3;HEXDEC("FF");HEXDEC("FFFF")) -> couleurs texte en rouge sur fond jaune en B3
'https://learn.microsoft.com/fr-fr/office/vba/language/reference/user-interface-help/color-constants
'------------------------------------------------------------------------
Function RangeProperties(ByVal Target As Range, _
                         Optional ByVal FontColor As Long = xlNone, _
                         Optional ByVal InteriorColor As Long = xlNone, _
                         Optional ByVal FontName As Variant = xlNone, _
                         Optional ByVal FontSize As Double = xlNone, _
                         Optional ByVal FontBold As Variant = xlNone, _
                         Optional ByVal FontItalic As Variant = xlNone, _
                         Optional ByVal FontUnderline As Variant = xlNone, _
                         Optional ByVal FontStrikethrough As Variant = xlNone)
    
    Dim TabCallerProperties(1 To 9) As Variant

    'Store the Properties into a Table
    Set TabCallerProperties(1) = Target
    TabCallerProperties(2) = FontColor
    TabCallerProperties(3) = InteriorColor
    TabCallerProperties(4) = FontName
    TabCallerProperties(5) = FontSize
    TabCallerProperties(6) = FontBold
    TabCallerProperties(7) = FontItalic
    TabCallerProperties(8) = FontUnderline
    TabCallerProperties(9) = FontStrikethrough
 
    'Store the Table into a Collection
    CallerCollection.Add TabCallerProperties
 
    'Async run of the setting of the Properties
    If TimerId = 0 Then
        TimerId = SetTimer(0, 0, 100, AddressOf SetRangeProperties)
    End If
End Function

Private Sub SetRangeProperties()
    Dim TabCallerProperties() As Variant
    Dim CalculationAtCallTime As Long
    Dim CalculationChange As Boolean
 
    KillTimer 0, TimerId
 
    Do While Not Application.Ready
        DoEvents
    Loop
 
    Do While CallerCollection.Count > 0
        TabCallerProperties = CallerCollection(1)
 
        With TabCallerProperties(1)
            'Set the Cell Value
            If UBound(TabCallerProperties) = 2 Then
                If Not CalculationChange Then
                    CalculationAtCallTime = Application.Calculation
                    Application.Calculation = xlCalculationManual
                    CalculationChange = True
                End If
 
                'The Cell might not exist anymore if deleted
                On Error Resume Next
                .Value = TabCallerProperties(2)
                On Error GoTo 0
 
            'Set the Range Properties
            Else
                If Not TabCallerProperties(2) = xlNone Then .Font.Color = TabCallerProperties(2)
                If Not TabCallerProperties(3) = xlNone Then .Interior.Color = TabCallerProperties(3)
                If Not TabCallerProperties(4) = xlNone Then .Font.Name = TabCallerProperties(4)
                If Not TabCallerProperties(5) = xlNone Then .Font.Size = TabCallerProperties(5)
                If Not TabCallerProperties(6) = xlNone Then .Font.Bold = TabCallerProperties(6)
                If Not TabCallerProperties(7) = xlNone Then .Font.Italic = TabCallerProperties(7)
                If Not TabCallerProperties(8) = xlNone Then .Font.Underline = TabCallerProperties(8)
                If Not TabCallerProperties(9) = xlNone Then .Font.Strikethrough = TabCallerProperties(9)
            End If
        End With
 
        CallerCollection.Remove (1)
    Loop
 
    If CalculationChange Then Application.Calculation = CalculationAtCallTime
    TimerId = 0
End Sub

Pour ne traiter QUE la couleur du texte de la cellule "Caller", une fonction personnalisée beaucoup plus simple peut être utilisée.

VB:
'-----------------------------------------------------------------
'Couleur du texte en cellule dont la formule concatène la fonction
'Exemple: ="Bonjour" & TextColor(255;0;0) -> texte en rouge
'-----------------------------------------------------------------
Function TextColor(ByVal R As Integer, ByVal G As Integer, ByVal B As Integer)
   Application.Caller.Font.Color = RGB(R, G, B)
End Function

Le fichier joint contient les modules correspondants et des exemples.
 

Pièces jointes

  • Fonction personnalisée propriétés et valeur de cellule.xlsm
    31.6 KB · Affichages: 0
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
312 817
Messages
2 092 366
Membres
105 379
dernier inscrit
alboub