Avoir le résultat d'une cellule en gras hormis l'unité

Le 16/03/2014 à 13:11

Bonjour à tous,

Je souhaite mettre le résultat de ma cellule B8 en gras sans que le reste du format ne change...

Aujourd'hui dans "Format de cellule/Nombre/Catégorie/Personnalisée" j'ai :

"blablabla "0" blablabla"

Je souhaite que seulement la valeur soit en gras et non le texte soit :

blablabla 0 blablabla

Est-ce possible?

30test.xlsx (8.69 Ko)
Le 16/03/2014 à 15:15

Bonjour

Je ne pense pas que cela soit possible avec un format personnalisé.

Tu sélectionnes la cellule concernée avant de lancer la macro

Sub FormatPersonnalise()
Dim Debut As String, Valeur As String, Fin As String, a As String, b As String

Debut = "blabla  "
Valeur = ActiveCell
Fin = "  blabla "

ActiveCell.Value = Debut & Valeur & Fin

a = Len(Debut)
b = Len(Valeur)

ActiveCell.Characters(Start:=a, Length:=b + 1).Font.Bold = True

End Sub

Amicalement

Nad

Le 16/03/2014 à 16:52

Merci! Ça fonctionne mais par contre cela supprime la formule de la case... Car le 0 était le résultat d'une formule "=B3/2"

Le 16/03/2014 à 17:20

Désolée mais je ne saurais pas faire mieux.

Amicalement

Nad

Le 16/03/2014 à 17:43

Bonjour Roden,

Bonjour Nad,

En couplant le code de Nad à une gestion évènementielle de la modification de la cellule B3, tu peux obtenir le résultat recherché.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
    If Target.Count > 1 Then Exit Sub
    If Target.Address = "$B$3" Then
        Debut = "blabla  "
        Valeur = Target / 2
        Fin = "  blabla "
        Range("B8").Value = Debut & Valeur & Fin
        a = Len(Debut)
        b = Len(Valeur)
        Range("B8").Characters(Start:=a, Length:=b + 1).Font.Bold = True
    End If
End Sub

A+

Le 16/03/2014 à 17:49

Bonjour frangy

Bien vu.

Amicalement

Nad

Le 16/03/2014 à 18:45

Merci à vous deux ça marche!

Mais comment puis-je mixer plusieurs Change/SelectionChange?

Car j'ai le droit à "nom" ambigu détecté faute du nombre (voici ma page) :

    Private Sub Worksheet_Change(ByVal Target As Range)
    Call Masque_lig
    End Sub
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
        If Target.Count > 1 Then Exit Sub
        If Target.Address = "$AH$15" Then
            Debut = "IL Y A "
            Valeur = Target
            Fin = " COURS DE PANNE SUR LE VERSANT. POUR ÉCONOMISER"
            Range("C15").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("C15").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If
    End Sub 
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
        If Target.Count > 1 Then Exit Sub
        If Target.Address = "$AI$15" Then
            Debut = "UN COURS DE PANNE IL FAUT RÉDUIRE LA VALEUR Z DE "
            Valeur = Target
            Fin = " mm"
            Range("Q15").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("Q15").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If
    End Sub 
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
        If Target.Count > 1 Then Exit Sub
        If Target.Address = "$AH$16" Then
            Debut = "IL Y A "
            Valeur = Target
            Fin = " PLAQUE(S) SUR LA LONGUEUR DU BÂTIMENT. POUR ÉCONOMISER"
            Range("C16").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("C16").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If
    End Sub 
    Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
        If Target.Count > 1 Then Exit Sub
        If Target.Address = "$AI$16" Then
            Debut = "UNE LIGNE DE PLAQUE IL FAUT RÉDUIRE LA VALEUR X DE "
            Valeur = Target
            Fin = " mm"
            Range("S16").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("S16").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If
    End Sub 
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("AF18:AF53")) Is Nothing Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Formula = "" Then Target.Formula = "X" Else Target.Formula = ""
    End Sub
Le 16/03/2014 à 19:26

Re

Tu regroupes les Worksheet_Change

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
        If Target.Count > 1 Then Exit Sub

        If Target.Address = "$AH$15" Then
            Debut = "IL Y A "
            Valeur = Target
            Fin = " COURS DE PANNE SUR LE VERSANT. POUR ÉCONOMISER"
            Range("C15").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("C15").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If

        If Target.Address = "$AI$15" Then
            Debut = "UN COURS DE PANNE IL FAUT RÉDUIRE LA VALEUR Z DE "
            Valeur = Target
            Fin = " mm"
            Range("Q15").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("Q15").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If

        If Target.Address = "$AH$16" Then
            Debut = "IL Y A "
            Valeur = Target
            Fin = " PLAQUE(S) SUR LA LONGUEUR DU BÂTIMENT. POUR ÉCONOMISER"
            Range("C16").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("C16").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If

        If Target.Address = "$AI$16" Then
            Debut = "UNE LIGNE DE PLAQUE IL FAUT RÉDUIRE LA VALEUR X DE "
            Valeur = Target
            Fin = " mm"
            Range("S16").Value = Debut & Valeur & Fin
            a = Len(Debut)
            b = Len(Valeur)
            Range("S16").Characters(Start:=a, Length:=b + 1).Font.Bold = True
        End If

         Call Masque_lig

    End Sub

Nad

Le 16/03/2014 à 20:00

Étrange... Cela à bien ajouté le texte à mes cellules mais la valeur n'est pas en gras et lorsque la cellule target change la valeur qui devrait être en gras ne change plus.

Le 16/03/2014 à 20:33

Re

Mon fichier TEST à l'air de fonctionner

27test.xlsm (20.17 Ko)

Nad

Le 16/03/2014 à 20:51

Effectivement. Mais ça ne marche pas si l'on met des formules dans les case AH15, AH16, AI15 et AI16

Le 16/03/2014 à 21:54
Roden a écrit :

Mais ça ne marche pas si l'on met des formules dans les case AH15, AH16, AI15 et AI16

C'est parce qu'il faut faire appel à une cellule qui est inscrite dans la formule

Exemple de formule en AH15 : =AH1/2

La macro concerne donc la Target AH1 ce qui donne :

If Target.Address = "$AH$1" Then 
 Debut = "IL Y A "
 Valeur = Range("AH15")
 Fin = " COURS DE PANNE SUR LE VERSANT. POUR ÉCONOMISER"
 Range("C15").Value = Debut & Valeur & Fin
 a = Len(Debut)
 b = Len(Valeur)
 Range("C15").Characters(Start:=a, Length:=b + 1).Font.Bold = True
 End If

Nad

Le 17/03/2014 à 18:36

Merci ça marche!

Concernant la protection de la page avec un mot de passe que faut-il ajouter au code?

Le 17/03/2014 à 18:44

Tu ajoutes

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Debut As String, Valeur As String, Fin As String, a As String, b As String
ActiveSheet.Unprotect ("TonMotDePasse")

.......
.......

ActiveSheet.Protect Password:="TonMotDePasse"
End Sub

Amicalement

Nad

Le 17/03/2014 à 19:50

J'ai un message d'erreur :

Erreur d'éxecution '1004';

Impossible de définir la propriété Bold de la classe Font.

qui m’amène vers la ligne :

Range("C16").Characters(Start:=a, Length:=b + 1).Font.Bold = True

Le 17/03/2014 à 20:15

Re

As-tu pensé à ajouter la déprotection/protection dans la Private Sub Worksheet_SelectionChange ?

Nad

Le 17/03/2014 à 20:41

Non je viens de le faire mais cela ne change rien

Le 17/03/2014 à 21:27

S'il fonctionnait sans la protection il n'y a pas de raison.

Si tu le veux, passe-moi ton fichier réel par mail que je regarde

nad_xlp@yahoo.fr

Le 17/03/2014 à 22:08

C'est envoyé! Merci par avance.

Rechercher des sujets similaires à "resultat gras hormis unite"