XL 2016 AIDE tri automatique avec images

Maathis

XLDnaute Nouveau
Bonjour à tous,

Je revient vers vous pour un problème avec une macro de tri automatique de ma base de données suivant un critère.
Je vais essayer d'être précis dans mes explications :D

Donc j'ai une base de données avec des images pour chaque donnée et sur une autre feuille, la gestion de telle sorte que les utilisateurs peuvent choisir leur critère et toutes les données comportant ce critère s'affichent.
J'utilise donc l'outil filtre avancé que j'ai pu enregistrer qui me donne:
VB:
  Application.CutCopyMode = False
    
    Sheets("Base").Range("Tableau1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("O7:O8"), CopyToRange:=Range("B11:G11"), Unique:= _
        False
        
    Range("E8").Select
Ce code marche bien pour les valeurs autres que les images mais mon souci est que j'aimerais bien qu'avec les données qui soient triées, leurs images correspondantes s'affichent aussi. Or j'ai bien sélectionné dans ma plage pour filtrer la colonne avec les images mais aucune n'image apparaît.

Si c'est possible, il faudrait que les images s'affichent aussi quand la macro copie la ligne et point supplémentaires que la ligne copiée garde la même hauteur, pour que l'image garde ses proportions.

Merci d'avance pour votre aide :)
 

Maathis

XLDnaute Nouveau
Merci j'ai pu chercher et je l'ai rajouté à mon code mais cela ne fonctionne toujours pas :(

VB:
    Application.CutCopyMode = False
    Application.CopyObjectsWithCells = True
    
    Sheets("Base").Range("Tableau1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("O7:O8"), CopyToRange:=Range("B11:G11"), Unique:=True
        
    Range("E8").Select

Merci
 

Maathis

XLDnaute Nouveau
Alors du coup j'ai créer un fichier de test et à ma grande surprise, les images s'inséraient aussi avec le texte au moment du filtrage des données.
Mais quand on change le sexe "homme" ou "femme" et qu'on effectue à nouveau un tri, les anciennes image restent en dessous des nouvelles.

Ce que j'aimerais bien c'est que dans mon fichier perso les images s'insèrent aussi mais qu'elle disparaissent quand on effectue à nouveau le tri pour d'autres données.

Je vous met ci-joint un fichier test avec aucune données confidentielles.

Merci à vous
 

Pièces jointes

  • Help_exemple.xlsm
    78.5 KB · Affichages: 2

patricktoulon

XLDnaute Barbatruc
re
VB:
Sub FiltreData()
    For Each shap In Sheets("Gestion").Shapes
        If shap.Name <> "bouton" Then shap.Delete
    Next
    With [B4:E1000]: .ClearContents: .Interior.Color = xlNone: End With
    
    Application.CopyObjectsWithCells = True
    With Sheets("BD").ListObjects("Tableau1").Range
        .AutoFilter Field:=3, Criteria1:=[I2].Text
        .SpecialCells(xlVisible).Copy Destination:=[B4]
        .AutoFilter
    End With
End Sub

tape homme ou femme en I1 et lance la sub

problème
en supprimant les shapes ca supprime la liste de validation
sinon c'est bon
 

Maathis

XLDnaute Nouveau
Merci pour ton aide, ton fichier fonctionne parfaitement comme j'aimerais que le mien fonctionne mais malheureusement je n'arrive pas a faire fonctionner le code, je pense qu'il doit y avoir un problème avec mes images. Je pense que je vais abandonner et garder la solution simple du filtre automatique pour les tableaux excel :rolleyes:

Merci beaucoup quand même pour votre aide.
 

Maathis

XLDnaute Nouveau
Bonjour,
Heureusement j'ai tout recommencé depuis le début et victoire ça marche parfaitement 🙌
J'ai repris ton code et j'ai adapté pour mes valeurs.
Milles merci pour ton aide, tu m'enlève une épine du pied.

Mais il reste un détail que j'aimerais enlever pour être perfectionniste.
En effet dans le filtrage automatique, la taille de mes valeurs change. Mais le tableau garde tous le temps la même taille donc j'ai une barre noir de fin de tableau qui me gêne.
Comment je pourrais faire pour assigner ma sélection à la nouvelle taille du tableau ?
Mon (ton) code :
Code:
    metier = CommandBars.ActionControl.Caption
    For Each shap In Sheets("Gestion").Shapes
        If shap.name <> "BTFiltre" And shap.name <> "BTRetour" And shap.name <> "BTSupp" Then
            shap.Delete
        End If
        
    Next
    Range("B6:G1000").Select
    With Selection
        .ClearContents
        .Interior.Color = xlNone
    End With
    
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    
    
    Application.CopyObjectsWithCells = True
    With Sheets("Base").ListObjects("Tableau1").Range
        .AutoFilter Field:=5, Criteria1:=metier
        .SpecialCells(xlVisible).Copy Destination:=[B5]
        .AutoFilter
    End With
    
    lastcell = Range("F10000").End(xlUp).Row
    Set Tableau13 = Range("B6:I" & lastcell)
J'ai essayé avec ça mais ça ne fonctionne pas :(
Code:
lastcell = Range("F10000").End(xlUp).Row
    Set Tableau13 = Range("B6:I" & lastcell)
 

Statistiques des forums

Discussions
288 581
Messages
1 893 168
Membres
169 778
dernier inscrit
kaka27O9
Haut Bas