Autres remplir bannière en fonction des cellules

[gh4]

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]

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 :

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 :

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]

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]

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]

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 :

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 :

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]

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]

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

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]

Bonjour gh4, sylvanu, patricktoulon,

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

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+