Mettre en gras les mots en majuscule
Bonjour,
Je souhaiterai mettre en gras les mots d'une cellule qui sont en entièrement en majuscule. Je voudrais aussi appliquer cela à mes colonnes B de toutes mes feuilles. Dans les colonnes B de chaque onglet j'ai des cellules avec cette information écrite sous ce format NOM Prénom (certains noms ont des particules mais au pire si c'est trop complexe à coder je mettrai un tiret)
Sub Formatmajuscules()
Dim DLig As Long, i As Long
Dim C As Range
Dim x As Variant
With Application
.ScreenUpdating = False
With Sheets("LUNDI")
DLig = .Cells(Rows.Count, 2).End(xlUp).Row
For Each C In Range("B2:B" & DLig)
For i = 1 To Len(C)
x = Mid(C, i, 1)
If x = UCase(x) Then
C.Characters(Start:=i, Length:=1).Font.Bold = True
Else
C.Characters(Start:=i, Length:=1).Font.Bold = False
End If
Next i
Next C
End With
.ScreenUpdating = True
End With
End Sub
J'ai trouvé un bout de code qui me met toutes majuscules en gras. Sauf que le la première lettre du prénom est en gras aussi. Deuxième souci, je n'arrive pas à appliquer la macro sur tous les onglets... J'ai essayé avec for each mais je n'arrive pas à faire fonctionner la macro...
Pouvez-vous m'aider SVP ?
Merci par avance
Bonjour,
A tester.
Sub LancerFormatMajusculesV2()
Dim I As Integer
Dim ListeDesOnglets As Variant
ListeDesOnglets = Array("LUNDI", "MARDI", "MERCREDI", "JEUDI", "VENDREDI")
For I = LBound(ListeDesOnglets) To UBound(ListeDesOnglets)
FormatMajusculesV2 Sheets(ListeDesOnglets(I))
Next I
End Sub
Sub FormatMajusculesV2(ByVal ShJour As Worksheet)
Dim I As Integer, J As Integer, NbMajuscule As Integer, PositionMot As Integer, DLig As Integer
Dim C As Range
Dim TableMots As Variant
'Application.ScreenUpdating = False
With ShJour
DLig = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("B2:B" & DLig).Font.Bold = False
For Each C In .Range("B2:B" & DLig)
TableMots = Split(C, " ")
For J = LBound(TableMots) To UBound(TableMots)
NbMajuscule = 0
For I = 1 To Len(TableMots(J))
If Mid(TableMots(J), I, 1) = UCase(Mid(TableMots(J), I, 1)) Then NbMajuscule = NbMajuscule + 1
Next I
If NbMajuscule = Len(TableMots(J)) Then
PositionMot = InStr(1, C.Value, TableMots(J), vbTextCompare)
C.Characters(Start:=PositionMot, Length:=Len(TableMots(J))).Font.Bold = True
End If
Next J
Next C
End With
' Application.ScreenUpdating = True
End Sub
Bonjour,
@Eric : +1
On peut aussi faire l'économie d'une boucle sur les caractères, boucle qui risque d'être chronophage en fonction des contenus des cellules :
For Each C In .Range("B2:B" & DLig)
TableMots = Split(C, " ")
For J = LBound(TableMots) To UBound(TableMots)
'NbMajuscule = 0
'For I = 1 To Len(TableMots(J))
' If Mid(TableMots(J), I, 1) = UCase(Mid(TableMots(J), I, 1)) Then NbMajuscule = NbMajuscule + 1
'Next I
'If NbMajuscule = Len(TableMots(J)) Then
' PositionMot = InStr(1, C.Value, TableMots(J), vbTextCompare)
' C.Characters(Start:=PositionMot, Length:=Len(TableMots(J))).Font.Bold = True
'End If
If TableMots(J) = UCase(TableMots(J)) Then
PositionMot = InStr(1, C.Value, TableMots(J), vbTextCompare)
C.Characters(Start:=PositionMot, Length:=Len(TableMots(J))).Font.Bold = True
End If
Next J
Next C
Merci beaucoup c'est top!!