Microsoft 365 Créer une barre de progression dans un tableau Excel

[applefanboy13200]

Bonjour,

Je viens solliciter votre aide pour savoir si quelqu'un saurait comment créer une barre de progression dans un tableau Excel (Pour être plus parlant, je vous ai joint un document Excel comprenant une barre de progression généré par l'extraction d'une plateforme).

L'idée serait qu'en rentrant le pourcentage dans la colonne de droite, la barre s'ajuste automatiquement en fonction.

Si vous avez une solution, ce serait top pour moi mais également pour toute la communauté !

 

[surchat]

Bonjour,
la fonction format conditionnelle, data bars (j'ai Excel en anglais, Conditional Formatiting Data Bars)

 

[excfl]

Bonsoir le forum,

Voir le fichier joint.

 

[surchat]

Super barbatruc,
Est-ce possible de faire la répétition proportionnel également à la largeur de la colonne, autrement dit, le 100% remplirait la largeur de la colonne?

 

[patricktoulon]

bonsoir
je reprend l'idée de excfl mais avec un peu de vba

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, v&, i&, coeff&, barre As Range, t&
    If Not Intersect(Target, [B2:B15]) Is Nothing Then
        For t = 1 To Target.Count
            r = 255: v = 0
            Set barre = Target(t).Offset(, 1)
            Debug.Print Target(t).Address
            If Target(t) = "" Then barre = ""
            barre = String(Round((20 / 100) * Val(Target(t).Value * 100)), "g")
            If Len(barre) > 20 Then barre = String(20, "g")
            If Len(barre) < 1 Then barre = "g"
            'If Val(Target.Value * 100) = 0 Or IsEmpty(Target(1)) Then barre = "": Exit Sub
            barre.Font.Color = vbGreen
            For i = 1 To Len(barre.Value)
                coeff = Round(255 / 20)
                r = r - coeff: r = IIf(r < 0, 0, r)
                v = v + coeff: v = IIf(v > 255, 255, v)
                barre.Characters(Start:=i, Length:=2).Font.Color = RGB(r, v, 0)
            Next
        Next
    End If
End Sub

on peut inverser les couleurs

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, v&, i&, coeff&, barre As Range, t&
    If Not Intersect(Target, [B2:B15]) Is Nothing Then
        For t = 1 To Target.Count
            r = 0: v = 255
            Set barre = Target(t).Offset(, 1)
            Debug.Print Target(t).Address
            If Target(t) = "" Then barre = ""
            barre = String(Round((20 / 100) * Val(Target(t).Value * 100)), "g")
            If Len(barre) > 20 Then barre = String(20, "g")
            If Len(barre) < 1 Then barre = "g"
            'If Val(Target.Value * 100) = 0 Or IsEmpty(Target(1)) Then barre = "": Exit Sub
            barre.Font.Color = vbRed
            For i = 1 To Len(barre.Value)
                coeff = Round(255 / 20)
                v = v - coeff: v = IIf(v < 0, 0, v)
                r = r + coeff: r = IIf(r > 255, 255, r)
                barre.Characters(Start:=i, Length:=2).Font.Color = RGB(r, v, 0)
            Next
        Next
    End If
End Sub

 

[patricktoulon]

version 3.0
le nombre de caractères s'adapte a la largeur de cellule

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, v&, i&, coeff&, barre As Range, t&, nbChar&
    If Not Intersect(Target, [B2:B15]) Is Nothing Then
        For t = 1 To Target.Count
            r = 0: v = 255
            Set barre = Target(t).Offset(, 1)
            barre.Font.Size = 6
            nbChar& = Round(barre.ColumnWidth - 2)
            Debug.Print Target(t).Address
            If Target(t) = "" Then barre = ""
            barre = String(Round((nbChar / 100) * Val(Target(t).Value * 100)), "g")
            If Len(barre) > 20 Then barre = String(20, "g")
            If Len(barre) < 1 Then barre = "g"
            'If Val(Target.Value * 100) = 0 Or IsEmpty(Target(1)) Then barre = "": Exit Sub
            barre.Font.Color = vbRed
            For i = 1 To Len(barre.Value)
                coeff = Round(255 / nbChar)
                v = v - coeff: v = IIf(v < 0, 0, v)
                r = r + coeff: r = IIf(r > 255, 255, r)
                barre.Characters(Start:=i, Length:=2).Font.Color = RGB(r, v, 0)
            Next
        Next
    End If
End Sub

correction coquille (20 codé en dur)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r&, v&, i&, coeff&, barre As Range, t&, nbChar&
    If Not Intersect(Target, [B2:B15]) Is Nothing Then
        For t = 1 To Target.Count
            r = 0: v = 255
            Set barre = Target(t).Offset(, 1)
            barre.Font.Size = 6
            nbChar& = Round(barre.ColumnWidth - 2)
            Debug.Print Target(t).Address
            If Target(t) = "" Then barre = ""
            barre = String(Round((nbChar / 100) * Val(Target(t).Value * 100)), "g")
            If Len(barre) > nbChar Then barre = String(nbChar, "g")
            If Len(barre) < 1 Then barre = "g"
            'If Val(Target.Value * 100) = 0 Or IsEmpty(Target(1)) Then barre = "": Exit Sub
            barre.Font.Color = vbRed
            For i = 1 To Len(barre.Value)
                coeff = Round(255 / nbChar)
                v = v - coeff: v = IIf(v < 0, 0, v)
                r = r + coeff: r = IIf(r > 255, 255, r)
                barre.Characters(Start:=i, Length:=2).Font.Color = RGB(r, v, 0)
            Next
        Next
    End If
End Sub