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: 07-11-2024 (Ajout de la possibilité de valoriser Interior.Pattern à xlNone pour revenir à la valeur par défaut (utile en particulier dans les Tableaux Structurés)
Version: 30-09-2024 (Ajout de la fonction personnalisée RangeValues())
Version: 16-08-2024 (Fonction CellValue(): empêche la ré-évaluation automatique par Excel)
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.
Inconvénient:
Puisque les propriétés sont définies en VBA dans les fonctions personnalisées, lors de l'exécution d'une de ces fonctions, on perd la pile des défaire/refaire (l'Undo Stack).
Il y a 4 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 passée sous forme de chaîne de caractères)
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")
La cellule B2 contiendra la valeur C2 + D2 soit 15.
A noter que CellValue et RangeProperties peuvent être utilisées dans la même formule.
Exemple en A3: = "Valeur et couleurs en B3" & CellValue(B3;"=C3 + D3") & RangeProperties(B3;HEXDEC("FF");HEXDEC("FFFF00"))
La cellule A3 contiendra la valeur C3 + D3 soit 15 et sera en caractères rouges ("FF") sur fond bleu ("FFFF00").
- RangeValues
Permet de définir les valeurs d'une plage de cellules quelconque qui ne contient pas la cellule qui contient la formule sous peine d'écraser la formule par la valeur indiquée.
Paramètres:
- Range concerné (type Range)
- Valeurs (type Variant, séparées par le séparateur de liste standard (";" (Fr) ou "," (En)), peut contenir des formules passées sous forme de chaînes de caractères)
Exemple en A7: = "Valeurs en B7:C7" & RangeValues(B7:C7;"Bonjour";"=C9")
La cellule B7 contiendra la valeur "Bonjour" et la cellule C7 contiendra C9 soit "à tous"
A noter que RangeValues et RangeProperties peuvent être utilisées dans la même formule.
Exemple en A5: = "Valeurs & couleurs en B5:C5" & RangeValues(B5:C5;"Bonjour";"à tous") & RangeProperties(B5:C5;HEXDEC("FF");HEXDEC("FFFF00"))
La cellule B5 contiendra la valeur "Bonjour", la cellule C5 contiendra "à tous" et les 2 cellules seront en caractères rouges ("FF") sur fond bleu ("FFFF00").
VB: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
Le fichier joint contient les modules correspondants et des exemples.
Pièces jointes
Dernière édition:
