Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

A

applefanboy13200

XLDnaute Nouveau
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é !
 

Pièces jointes

  • Satisfaction.xlsx
    9.7 KB · Affichages: 14
Trier par date Trier par votes

patricktoulon

XLDnaute Barbatruc
bonsoir
je reprend l'idée de excfl mais avec un peu de vba
VB: 
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
VB: 
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
 

Pièces jointes

  • Barre de progression V pat .xls
    44 KB · Affichages: 11
Dernière édition:
Vote positif 0 Vote négatif

patricktoulon

XLDnaute Barbatruc
version 3.0
le nombre de caractères s'adapte a la largeur de cellule
VB: 
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)
VB: 
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
 
Dernière édition:
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

F
  • Question
XL 2019 VBA et Power Query - Barre de progression
Réponses
10
Affichages
365
crocrocro
C
S
  • Question
Microsoft 365 Barre de progression sur un %
Réponses
3
Affichages
207
crocrocro
C
  • Question
XL 2021 Barre de progression dans une listview - Tableau structuré avec barre de donnée dans la listview
Réponses
2
Affichages
500
AHK
  • Résolu(e)
Microsoft 365 Forcer l'affichage de mon userform (barre de progression) sur l'écran où le classeur est actif (cas des doubles/triples écrans)
3 4 5
Réponses
66
Affichages
2 K
Dudu2
G
  • Question
Google Sheets Barre de progression google sheet
Réponses
0
Affichages
675
Gregous
G
B
  • Résolu(e)
XL 2013 Barre de progression.
Réponses
7
Affichages
773
fanfan38
  • Résolu(e)
Microsoft 365 Programme de lecture d'un très gros livre (3 différents livres par semaine et un chapitre de chaque par jour)
2
Réponses
18
Affichages
653
crocrocro
C
L
  • Question
XL 2016 Création d'une étiquette CB avec Excel
Réponses
5
Affichages
485
lincoln75
L
A
  • Question
Microsoft 365 Barre de progression
Réponses
5
Affichages
908
ADS95
A
T
  • Question
Microsoft 365 Lisibilité et compréhensibilité tableau
Réponses
1
Affichages
115
JHA
J
M
  • Résolu(e)
XL 2016 comment créer une Barre de défilement ou faire simplement défiler son texte ?
2
Réponses
25
Affichages
1 K
melltel
M
S
  • Question
XL 2021 Planning de suivi des actions pour service Hygiène Sécurité et Environnement
Réponses
2
Affichages
856
fanfan38
R
  • Résolu(e)
XL 2016 Créer un .doc à partir des données d'un tableur
Réponses
9
Affichages
344
job75
Y
  • Question
XL 2016 Création d'un publipostage avec PJ PDF sur Outlook
Réponses
2
Affichages
155
Phil69970
H
  • Question
XL 2016 Comment calculer le nombre de chiffres différents dans une même cellule excel ?
Réponses
6
Affichages
311
jurassic pork
T
  • Question
Microsoft 365 Afficher des résultats en colonne sous forme de ligne
Réponses
6
Affichages
123
JHA
J
P
  • Question
Autres tableau Excel incluant un planning détaillé pour les salariés et les enfants
Réponses
2
Affichages
220
w36xb2w
W
J
  • Résolu(e)
XL 2013 Créer une macro avec un fichier pour envoyer par mail
Réponses
7
Affichages
353
TooFatBoy
N
  • Résolu(e)
Microsoft 365 KANBAN dans Excel
Réponses
8
Affichages
233
sylvanu
V
  • Question
Microsoft 365 Créer un fichier élève avec présences, groupes et fiche personnelle de commentaire par élève....
Réponses
3
Affichages
358
Phil69970
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…