Autres remplir bannière en fonction des cellules

gh4 · 22 Octobre 2022

bonjour à toutes et tous,

j'aimerai créer un résumé d'une feuille, sur une bannière ou autre chose en fonction de certaines cellules
mais je ne sais pas si cela est réalisable
Auriez vous des suggestions à me faire en partant du fichier joint
Par avance merci
cdt

sylvanu · 22 Octobre 2022

Bonjour GH4,
Un essai en PJ. Je n'utilise pas la MFC mais la reconstitue en VBA, car ma version VBA 6.3 ne permet pas facilement d'extraire la couleur MFC d'une cellule. Avec :

VB:

Sub Macro2()
    Application.ScreenUpdating = False
    For L = 3 To Range("A65500").End(xlUp).Row
        If Cells(L, "C") > Cells(L, "B") Then
            Texte = Texte & Cells(L, "A") & Chr(10)
        End If
    Next L
    Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5)
    objShp.Name = "Bannière"
    ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = Texte
End Sub

Addon : Si vous disposez d'une version VBA > 6.3 alors vous pouvez tenter :

VB:

Sub Macro2()
    Application.ScreenUpdating = False...

sylvanu · 22 Octobre 2022

Bonjour GH4,
Un essai en PJ. Je n'utilise pas la MFC mais la reconstitue en VBA, car ma version VBA 6.3 ne permet pas facilement d'extraire la couleur MFC d'une cellule. Avec :

VB:

Sub Macro2()
    Application.ScreenUpdating = False
    For L = 3 To Range("A65500").End(xlUp).Row
        If Cells(L, "C") > Cells(L, "B") Then
            Texte = Texte & Cells(L, "A") & Chr(10)
        End If
    Next L
    Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5)
    objShp.Name = "Bannière"
    ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = Texte
End Sub

Addon : Si vous disposez d'une version VBA > 6.3 alors vous pouvez tenter :

VB:

Sub Macro2()
    Application.ScreenUpdating = False
    For L = 3 To Range("A65500").End(xlUp).Row
        If Cells(L, "D").DisplayFormat.Interior.Color = vbRed Then
            Texte = Texte & Cells(L, "A") & Chr(10)
        End If
    Next L
    Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5)
    objShp.Name = "Bannière"
    ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = Texte
End Sub

".DisplayFormat.Interior.Color" permet de lire la couleur donnée par la MFC.
( attention, évidemment non testée )

patricktoulon · 22 Octobre 2022

Bonjour @gh4
question : pourquoi XLS alors que tu travaille sur 2019 ?
c'est un xlsm version supérieur à 2003
sinon c'est simple
voici une démo

gh4 · 22 Octobre 2022

patricktoulon à dit:
Bonjour @gh4
question : pourquoi XLS alors que tu travaille sur 2019 ?
c'est un xlsm version supérieur à 2003
sinon c'est simple
voici une démo

Bonjour,
merci pour la reponse
je suis sur excel 2003
j'ai teste votre programme mais je bloque sur
If plage.Cells(i, 4).DisplayFormat.Interior.Color = vbRed Then
est ce que cela provient que les cellules en rouge sont des mfc

gh4 · 22 Octobre 2022

sylvanu à dit:
Bonjour GH4,
Un essai en PJ. Je n'utilise pas la MFC mais la reconstitue en VBA, car ma version VBA 6.3 ne permet pas facilement d'extraire la couleur MFC d'une cellule. Avec :

VB:

Sub Macro2() Application.ScreenUpdating = False For L = 3 To Range("A65500").End(xlUp).Row If Cells(L, "C") > Cells(L, "B") Then Texte = Texte & Cells(L, "A") & Chr(10) End If Next L Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5) objShp.Name = "Bannière" ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = Texte End Sub

Addon : Si vous disposez d'une version VBA > 6.3 alors vous pouvez tenter :

VB:

Sub Macro2() Application.ScreenUpdating = False For L = 3 To Range("A65500").End(xlUp).Row If Cells(L, "D").DisplayFormat.Interior.Color = vbRed Then Texte = Texte & Cells(L, "A") & Chr(10) End If Next L Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5) objShp.Name = "Bannière" ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = Texte End Sub

".DisplayFormat.Interior.Color" permet de lire la couleur donnée par la MFC.
( attention, évidemment non testée )

bonjour sylvanu
votre solution fonctionne parfaitement j'ai pris la version <6.3 car je suis en 6.3
je vais encore abuser s'il y a des doublons sur la colonne A comment je peux les éliminer et qu'il n'apparaissent pas dans la banniere

patricktoulon · 22 Octobre 2022

gh4 à dit:
Bonjour,
merci pour la reponse
je suis sur excel 2003
j'ai teste votre programme mais je bloque sur
If plage.Cells(i, 4).DisplayFormat.Interior.Color = vbRed Then
est ce que cela provient que les cellules en rouge sont des mfc

alors pourquoi a tu mis 2019 dans ton profil

sylvanu · 22 Octobre 2022

Re,
@gh4,
Il suffit de vérifier qu'avant la ligne considérée l'item n'existe pas, avec :

VB:

Sub Macro2()
    Dim DL%, L%, texte$
    Application.ScreenUpdating = False
    DL = Range("A65500").End(xlUp).Row
    For L = 3 To DL
        If Cells(L, "C") > Cells(L, "B") Then
            If Application.CountIf(Range(Cells(2, "A"), Cells(L - 1, "A")), Cells(L, "A")) = 0 Then
                texte = texte & Cells(L, "A") & Chr(10)
            End If
        End If
    Next L
    Set objShp = ActiveSheet.Shapes.AddShape(msoShapeVerticalScroll, 329.25, 99.75, 346.5, 391.5)
    objShp.Name = "Bannière"
    ActiveSheet.Shapes("Bannière").TextFrame.Characters.Text = texte
End Sub

job75 · 22 Octobre 2022

Bonjour gh4, sylvanu, patricktoulon,

Je ne vois pas l'intérêt d'une "bannière", voyez le fichier joint et ces macros :

VB:

Sub Filtrer()
Application.ScreenUpdating = False
With Range("D1:D" & Range("A" & Rows.Count).End(xlUp).Row)
    .Formula = "=1/(C1>B1)/(MATCH(A1,A:A,0)=ROW())"
    .SpecialCells(xlCellTypeFormulas, 16).EntireRow.Hidden = True 'masque
    .ClearContents
End With
End Sub

Sub RAZ()
Rows.Hidden = False 'affiche
End Sub

Les doublons en colonne A ne sont pas affichés.

A+

Autres remplir bannière en fonction des cellules

gh4

XLDnaute Occasionnel

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

Pièces jointes

gh4

XLDnaute Occasionnel

gh4

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires