mise en forme

Sub SixEnRouge()

'[COLOR=Red]Attention[/COLOR] : les valeurs de cellules avec [SIZE=4]⑥[SIZE=2] ne seront plus considérées comme numériques.

[/SIZE][/SIZE]Dim i As Integer
Dim C As Range
Dim TP As Byte
For Each C In Selection ' à adapter
  'remplace les 6 par le caractère unicode 6 cerclé  [SIZE=4]⑥[/SIZE]
  C = Replace(C, 6, ChrW(&H2465))  'ChrW(9317) = ChrW(&H2465), le &H indique une valeur héxadécimale
  TP = C.Font.Size + 1 'agrandissement de la police pour les [SIZE=4]⑥[/SIZE]
  For i = 1 To Len(C)
    'on mets les [SIZE=4]⑥[/SIZE] en gras rouge et on augmente la taille de police d'un point
    If Mid(C, i, 1) = ChrW(9317) Then
      C.Characters(Start:=i, Length:=1).Font.Bold = True
      C.Characters(Start:=i, Length:=1).Font.ColorIndex = 3
      C.Characters(Start:=i, Length:=1).Font.Size = TP
    End If
  Next i
Next C
[SIZE=4][/SIZE]
End Sub

Sub Sixercle()
'Inscrit un 6 cerclé en rouge dans la cellule active
    ActiveCell.FormulaR1C1 = "o"
    With ActiveCell.Characters(Start:=1, Length:=1).Font
        .Name = "Wingdings 2"
        .FontStyle = "Normal"
        .Size = 12
        .ColorIndex = 3
    End With
End Sub

Sub Sicercle()
[COLOR=Blue] Dim Tsh As String, Rsh As String
Dim Tf, Lf, Wf, Hf, Ti, Li, Rh, Rw As Double
Dim Cel As Range[/COLOR]

Set Cel = ActiveCell
Wi = 11.25  '***Convient à une police 8
Hi = 11.25

[COLOR=DarkGreen] '***Détermine les caractéristiques de la cellule de réception de l'image[/COLOR]
Tf = Cel.Top
Lf = Cel.Left
Wf = Cel.Width
Hf = Cel.Height

Ti = Lf + Wf / 2 - Hi / 2
Li = Tf + Hf / 2 - Wi / 2
[COLOR=DarkGreen]
'***Insère une zone de texte avec un 6[/COLOR]
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Ti, Li, Wi, Hi).Select
    With Selection
        .Characters.Text = "6"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Tsh = Selection.Name
    With Selection.Characters(Start:=1, Length:=1).Font
        .Name = "Arial"
        .FontStyle = "Normal"
        .Size = 8
    End With
    With Selection.ShapeRange
        .Fill.ForeColor.SchemeColor = 65
        .Fill.Transparency = 1#
        .Line.Transparency = 1#
        .Line.Visible = msoFalse
    End With
    
[COLOR=DarkGreen] '***Insère un rond[/COLOR]
ActiveSheet.Shapes.AddShape(msoShapeOval, Ti, Li, Wi, Hi).Select
Rsh = Selection.Name
    With Selection.ShapeRange
        .Fill.Transparency = 1#
        .Line.Visible = msoTrue
        .Line.ForeColor.SchemeColor = 10
        .Line.BackColor.RGB = RGB(255, 255, 255) '***ligne en rouge
    End With
    
[COLOR=DarkGreen] '***Aligne les deux formes (Normalement superfétatoire)[/COLOR]
ActiveSheet.Shapes.Range(Array(Tsh, Rsh)).Select
Selection.ShapeRange.Align msoAlignMiddles, False
Selection.ShapeRange.Align msoAlignCenters, False
End Sub

Sub Sicercle()
[COLOR=Blue] Dim Tsh As String, Rsh As String
Dim Tf, Lf, Wf, Hf, Ti, Li, Rh, Rw As Double
Dim Cel As Range[/COLOR]

Set Cel = ActiveCell
Wi = 11.25  [COLOR=Green]'***Convient à une police 8[/COLOR]
Hi = 11.25
[COLOR=Green]
'***Détermine les caractéristiques de la cellule de réception de l'image[/COLOR]
Tf = Cel.Top
Lf = Cel.Left
Wf = Cel.Width
Hf = Cel.Height

Ti = Lf + Wf / 2 - Hi / 2
Li = Tf + Hf / 2 - Wi / 2
[COLOR=Green]
'***Insère une zone de texte avec un 6[/COLOR]
Tsh = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, Ti, Li, Wi, Hi).Name
    ActiveSheet.Shapes(Tsh).Select
    With Selection
        .Characters.Text = "6"
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Characters(Start:=1, Length:=1).Font
            .Name = "Arial"
            .FontStyle = "Normal"
            .Size = 8
        End With
        With .ShapeRange
            .Fill.ForeColor.SchemeColor = 65
            .Fill.Transparency = 1#
            .Line.Transparency = 1#
            .Line.Visible = msoFalse
        End With
    End With
    
[COLOR=Green] '***Insère un rond[/COLOR]
Rsh = ActiveSheet.Shapes.AddShape(msoShapeOval, Ti, Li, Wi, Hi).Name
    With ActiveSheet.Shapes(Rsh)
        .Fill.Transparency = 1#
        .Line.Visible = msoTrue
        .Line.ForeColor.SchemeColor = 10
        .Line.BackColor.RGB = RGB(255, 255, 255) '***ligne en rouge
    End With
    
End Sub

Option Explicit
' [COLOR=Red]Chemin du SixRouge à adapter[/COLOR]
Private Const GifImage As String = "C:\Users\Fred\Desktop\6.gif"
Sub SixRouge()
Dim i As Integer
Dim C As Range
Dim monTab As Variant
Dim Sh As Shape

monTab = Array()

' suppression des shapes de la feuille, à adapter si tu as déjà des shapes hormis les SixRouges
For Each Sh In ActiveSheet.Shapes
Sh.Delete
Next

For Each C In Selection ' [COLOR=Red]à adapter[/COLOR]
  'recherche des cellules contenant un 6
  If InStr(1, C, 6) > 0 Then
    'insertion des adresses dans un tableau
    ReDim Preserve monTab(UBound(monTab) + 1)
    monTab(UBound(monTab)) = C.Address
  End If
Next C
' insertion des SixRouges
For i = 0 To UBound(monTab)
  InsererSixRouge monTab(i)
Next
End Sub
' procédure pour insérer les SixRouges dans le coin supérieur gauche des cellules.
Sub InsererSixRouge(Adresse As Variant)
Dim SixRouge As Object
Set SixRouge = ActiveSheet.Pictures.Insert(GifImage)
Dim T As Long
Dim L As Long
T = Range(Adresse).Top
L = Range(Adresse).Left
SixRouge.Top = T
SixRouge.Left = L
Set SixRouge = Nothing
End Sub

For Each C In Selection ' [COLOR=Red]à adapter[/COLOR]
  'recherche des cellules contenant un 6
  If InStr(1, C, 6) > 0 Then
    'insertion des adresses dans un tableau
    ReDim Preserve monTab(UBound(monTab) + 1)
    monTab(UBound(monTab)) = C.Address
  End If
Next C

  If InStr(1, C, 6) > 0 And TOTO > TITI Then