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!!