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. |
Version: 16-08-2024 (voir Post suivant)
Ces fonctions s'utilisent par concaténation (&) ou par somme (+) dans les formules selon le type souhaité de la valeur résultat. Dans les 2 cas, elles n'ont aucun effet sur le résultat.
Il y a 3 fonctions personnalisées:
- 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.
Paramètres (tous optionnels):
- Couleur de fonte (type Long)
- Couleurs de fond (type Long)
- Nom de la fonte (type String)
- Taille de la fonte (type Integer / Single / Double)
- Gras (type Boolean)
- Italique (type Boolean)
- Gras (type Boolean)
- Souligné (type Variant, Énumération XlUnderlineStyle)
- Barré (type Boolean)
Exemple: = "Bonjour" & CallerProperties(HEXDEC("FF");HEXDEC("FFFF"))
La cellule contenant la formule sera en caractères rouges ("FF") sur fond jaune ("FFFF").
- RangeProperties
Permet de définir les propriétés d'une plage de cellules quelconque désignée dans la formule.
Paramètres (tous optionnels sauf le 1er):
- Range concerné (type Range)
- Couleur de fonte (type Long)
- Couleurs de fond (type Long)
- Nom de la fonte (type String)
- Taille de la fonte (type Integer / Single / Double)
- Gras (type Boolean)
- Italique (type Boolean)
- Gras (type Boolean)
- Souligné (type Variant, Énumération XlUnderlineStyle)
- Barré (type Boolean)
Exemple en A3: = "Couleurs en B3:C3" & RangeProperties(B3:C3;HEXDEC("FF");HEXDEC("FFFF"))
Les cellules B3:C3 seront en caractères rouges ("FF") sur fond jaune ("FFFF").
- CellValue
Permet de définir la valeur d'une cellule quelconque qui n'est pas la cellule qui contient la formule sous peine d'écraser la formule par la valeur indiquée.
Paramètres:
- Cellule concerné (type Range)
- Valeur (type Variant, peut être une formule)
Exemple en A2: = "Valeur en B2" & CellValue(B2;"Bonjour")
La cellule B2 contiendra la valeur "Bonjour".
Exemple en A2: = "Valeur en B2" & CellValue(B2;"=C2 + D2")
Le cellule B2 contiendra la valeur 15.
A noter que CellValue et RangeProperties peuvent être utilisées dans la même formule.
Exemple en A4: = "Valeurs & couleurs en B4:C4" & CellValue(B4;"Bonjour") & CellValue(C4;"à tous") & RangeProperties(B4:C4;HEXDEC("FF");HEXDEC("FFFF00"))
VB:
Option Explicit
'------------------
'Version 16/08/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
'
'-----------------------------------------------------------------------------------------------------------------------------------------------
'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
'------------------------------------------------------------------------
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
'----------------------------------------------------------------------------------
'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
'----------------------------------------------------------------------------------
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 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
'--------------------------------------------------------------------------------
Function CellValue(ByVal Target As Range, _
ByVal Value 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) = Value
'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
KillTimer 0, TimerId
Do While Not Application.Ready
DoEvents
Loop
Do While SetPropertiesCollection.Count > 0
TabProperties = SetPropertiesCollection(1)
With TabProperties(1)
'Set the Cell Value
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 Cell might not exist anymore if deleted
On Error Resume Next
.Value = TabProperties(2)
On Error GoTo 0
ExcelCalculation = False
'Set the Range Properties
Else
If Not TabProperties(2) = xlNone Then .Font.Color = TabProperties(2)
If Not TabProperties(3) = xlNone Then .Interior.Color = TabProperties(3)
If Not TabProperties(4) = xlNone Then .Font.Name = TabProperties(4)
If Not TabProperties(5) = xlNone Then .Font.Size = TabProperties(5)
If Not TabProperties(6) = xlNone Then .Font.Bold = TabProperties(6)
If Not TabProperties(7) = xlNone Then .Font.Italic = TabProperties(7)
If Not TabProperties(8) = xlNone Then .Font.Underline = TabProperties(8)
If Not TabProperties(9) = xlNone Then .Font.Strikethrough = TabProperties(9)
End If
End With
SetPropertiesCollection.Remove (1)
Loop
TimerId = 0
End Sub
Le fichier joint contient les modules correspondants et des exemples.
Pièces jointes
Dernière édition: