Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
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 SubSub 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 SubSub 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 SubOption 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 SubPar macro, ma dernière proposition convient parfaitement à ce cas de figure à condition que tu n'aies pas besoin d'utiliser le résultat.
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 ThenJe suis entièrement d'accord avec Fred. Personnellement je ne sais plus ce que tu recherches... ni comment tu souhaites l'obtenir...
