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

Option Explicit
'------------------
'Version 07/11/2024
'------------------

#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 SetPropertiesCollection As New Collection
Private TimerId As Long
Private Const NoValue = xlNone
'
'-----------------------------------------------------------------------------------------------------------------------------------------------
'Quand la fonction CellValue() affecte une valeur dans la cellule indiquée, la formule qui la contient sera automatiquement ré-évaluée par Excel
'si Application.Calculation <> xlCalculationManual car la cellule modifiée fait partie des arguments de la fonction CellValue().
'Ce flag permet d'inhiber les traitements issus de cette ré-évaluation automatique qui a lieu immédiatement après l'affectation de la valeur.
'-----------------------------------------------------------------------------------------------------------------------------------------------
Private ExcelCalculation As Boolean

'------------------------------------------------------------------------
'Propriétés de la cellule dont la formule concatène ou ajoute 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
'
'Si InteriorColor = -1 alors la paterne de la cellule est mise à xlNone (valeur par défaut)
'------------------------------------------------------------------------
Function CallerProperties(Optional ByVal FontColor As Long = NoValue, _
                          Optional ByVal InteriorColor As Long = NoValue, _
                          Optional ByVal FontName As Variant = NoValue, _
                          Optional ByVal FontSize As Double = NoValue, _
                          Optional ByVal FontBold As Variant = NoValue, _
                          Optional ByVal FontItalic As Variant = NoValue, _
                          Optional ByVal FontUnderline As Variant = NoValue, _
                          Optional ByVal FontStrikethrough As Variant = NoValue)
 
    RangeProperties Application.Caller, FontColor, InteriorColor, FontName, FontSize, FontBold, FontItalic, FontUnderline, FontStrikethrough
End Function
                
'----------------------------------------------------------------------------------
'Propriétés d'une plage quelconque dont une formule concatène ou ajoute 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
'
'Si InteriorColor = -1 alors la paterne du Range est mise à xlNone  (valeur par défaut)
'----------------------------------------------------------------------------------
Function RangeProperties(ByVal Target As Range, _
                         Optional ByVal FontColor As Long = NoValue, _
                         Optional ByVal InteriorColor As Long = NoValue, _
                         Optional ByVal FontName As Variant = NoValue, _
                         Optional ByVal FontSize As Double = NoValue, _
                         Optional ByVal FontBold As Variant = NoValue, _
                         Optional ByVal FontItalic As Variant = NoValue, _
                         Optional ByVal FontUnderline As Variant = NoValue, _
                         Optional ByVal FontStrikethrough As Variant = NoValue)
                     
    Dim TabProperties(1 To 9) As Variant

    'Ré-évaluation automatique de la formule par Excel
    If ExcelCalculation Then Exit Function
 
    'Store the Properties into a Table
    Set TabProperties(1) = Target
    TabProperties(2) = FontColor
    TabProperties(3) = InteriorColor
    TabProperties(4) = FontName
    TabProperties(5) = FontSize
    TabProperties(6) = FontBold
    TabProperties(7) = FontItalic
    TabProperties(8) = FontUnderline
    TabProperties(9) = FontStrikethrough
 
    'Store the Table into a SetPropertiesCollection
    SetPropertiesCollection.Add TabProperties
     
    'Async run of the setting of the Properties
    If TimerId = 0 Then
        TimerId = SetTimer(0, 0, 100, AddressOf SetTargetProperties)
    End If
End Function

'--------------------------------------------------------------------------------
'Valeur d'une cellule quelconque dont une formule concatène ou ajoute la fonction
'Exemple en A2: = "Valeur en B2" & CellValue(B2;"Bonjour") -> Valeur "Bonjour" en B2
'La valeur peut contenir une formule passée sous forme de chaînes de caractères
'--------------------------------------------------------------------------------
Function CellValue(ByVal Target As Range, _
                   ByVal Value As Variant)
                    
    RangeValues Target, Value
End Function

'-------------------------------------------------------------------------------------------
'Valeurs d'une plage de cellules quelconque dont une formule concatène ou ajoute la fonction
'Les valeurs sont séparées par le séparateur de liste standard (";" (Fr) ou "," (En))
'Les valeurs peuvent contenir des formules passées sous forme de chaînes de caractères
'Exemple en A2: = "Valeur en B2:C2" & RangeValues(B2:C2;"Bonjour";"à tous") -> Valeur "Bonjour" en B2 et "à tous" en C2
'-------------------------------------------------------------------------------------------
Function RangeValues(ByVal Target As Range, _
                     ParamArray TabValues() As Variant)
                    
    Dim TabProperties(1 To 2) As Variant
 
    'Ré-évaluation automatique de la formule par Excel
    If ExcelCalculation Then Exit Function
 
    'Store the Value into a Table
    Set TabProperties(1) = Target
    TabProperties(2) = TabValues
 
    'Store the Table into a Collection
    SetPropertiesCollection.Add TabProperties
 
    'Async run of the setting of the Properties
    If TimerId = 0 Then
        TimerId = SetTimer(0, 0, 100, AddressOf SetTargetProperties)
    End If
End Function

'------------------------------------------------------------
'Fonction d'exécution des actions empilées dans la Collection
'------------------------------------------------------------
Private Sub SetTargetProperties()
    Dim TabProperties() As Variant
    Dim TabValues() As Variant
    Dim Cell As Range
    Dim i As Integer
 
    KillTimer 0, TimerId
 
    Do While SetPropertiesCollection.Count > 0
        TabProperties = SetPropertiesCollection(1)
     
        With TabProperties(1)
            'Set the Cell Value or Range Values
            If UBound(TabProperties) = 2 Then
                'Inhibe l'appel des fonctions issu de la ré-évaluation automatique par Excel lors de la modification de la valeur
                ExcelCalculation = True
             
                'The Cells might not exist anymore if deleted
                On Error Resume Next
                TabValues = TabProperties(2)
                i = LBound(TabValues)
                For Each Cell In .Cells
                    If i > UBound(TabValues) Then
                        Exit For
                    End If
                    Cell.Value = TabValues(i)
                    i = i + 1
                Next Cell
                On Error GoTo 0
             
                ExcelCalculation = False
             
            'Set the Range Properties
            Else
                If Not TabProperties(2) = NoValue Then .Font.Color = TabProperties(2)
                If Not TabProperties(3) = NoValue Then
                    If TabProperties(3) = -1 Then
                        .Interior.Pattern = xlNone
                    Else
                        .Interior.Color = TabProperties(3)
                    End If
                End If
                If Not TabProperties(4) = NoValue Then .Font.Name = TabProperties(4)
                If Not TabProperties(5) = NoValue Then .Font.Size = TabProperties(5)
                If Not TabProperties(6) = NoValue Then .Font.Bold = TabProperties(6)
                If Not TabProperties(7) = NoValue Then .Font.Italic = TabProperties(7)
                If Not TabProperties(8) = NoValue Then .Font.Underline = TabProperties(8)
                If Not TabProperties(9) = NoValue Then .Font.Strikethrough = TabProperties(9)
            End If
        End With
     
        SetPropertiesCollection.Remove (1)
    Loop
 
    TimerId = 0
End Sub