XL 2016 Images dans tableau structuré

[fanch55]

Bonjour à tous,
Je rencontre une bizarrerie dans Excel : J'ai un tableau structuré (Tableau1) .
Une des colonnes contient des images ( une par ligne ) .
Quand je veux vider ce tableau, toutes les lignes sont "vidées" : contenu des cellules etc..
mais il me reste imperturbablement toujours l'image de la première ligne même si la ligne de tableau n'existe plus ( par code ou manuellement ....)

C'est un peu ch... surtout que je ne comprend pas pourquoi ...

Auriez-vous une astuce ou une raison à celà ?

Pour charger les lignes du tableau et des image, cliquer sur "Load"
Pour effacer les lignes, cliquez sur "Clear" ou sélectionnez les lignes et clic-droit: supprimer les lignes du tableau

 

[Dudu2]

Bonjour,
Ah, la 1ère ligne des tableaux structurés qui est là sans être là quand le DataBodyRange is Nothing !
Un vrai cauchemar. J'ai passé des heures et des heures juste pour faire une fonction de Resize du DataBodyRange en gérant les comportements improbables d'Excel (avec ou sans Header Row ou Totals Row) sur les tableaux structurés.

En fait tu ne peux pas te débarrasser de l'image comme ça, il faut la supprimer spécifiquement.

Sub Efface()
    Dim Sh As Shape
   
    With [tableau1].Parent.ListObjects("tableau1")
        If Not .DataBodyRange Is Nothing Then
            For Each Sh In [tableau1].Parent.Shapes
                If Sh.Top = .ListColumns("Image").DataBodyRange.Cells(1).Top + 4 Then
                    Sh.Delete
                    Exit For
                End If
            Next Sh
       
            .DataBodyRange.Delete
        End If
    End With
   
   
    'If Not [tableau1].ListObject.DataBodyRange Is Nothing Then [Tableau1[#Data]].Delete
End Sub

 

[fanch55]

Salut @Dudu2

En fait tu ne peux pas te débarrasser de l'image comme ça, il faut la supprimer spécifiquement.

Ah ça, je voulais l'éviter.
D'après le code, il faut détruire les shapes avant les rows, c'est pas fun ... ( les shapes concernent-ils le tableau ? ), ça va être lourd : tester les intersect , grrrrr ...

 

[Dudu2]

Dans le code ci-dessus on ne .Delete que la Shape de la 1ère ligne, pas toutes.
Les Shapes ne sont pas vues comme contenu du tableau, donc tu n'y coupes pas de les traiter séparément, sauf que dans la suppression effectives des lignes 2 à N, elles disparaissent parce qu'incluses dans les lignes du tableau supprimées. Alors que la ligne 1 n'est pas physiquement supprimée.

D'ailleurs il serait plus logique de les supprimer toutes avant de supprimer les lignes du tableau.

 

[Dudu2]

Supprime toutes les Shapes d'abord...

Sub Efface()
    Dim Sh As Shape
    Dim Cell As Range
   
    With [tableau1].ListObject
        If Not .DataBodyRange Is Nothing Then
            For Each Cell In .ListColumns("Image").DataBodyRange.Cells
                For Each Sh In [tableau1].Parent.Shapes
                    If Sh.Top = Cell.Top + 4 Then
                        Sh.Delete
                        Exit For
                    End If
                Next Sh
            Next Cell
       
            .DataBodyRange.Delete
        End If
    End With
End Sub

 

[fanch55]

Bon, j'ai peut-être un code par dépit qui fonctionne :
Attention l'ordre est important l'image.delete avant le tableau.delete

Sub Efface()
    For Each Image In ActiveSheet.Pictures
        If Not Intersect(Image.TopLeftCell, [Tableau1[Image]]) Is Nothing Then Image.Delete
    Next
    If Not [Tableau1].ListObject.DataBodyRange Is Nothing Then [Tableau1[#Data]].Delete
End Sub

Merci @Dudu2, tu m'as mis sur la voie ...

 

[fanch55]

Oki, si personne n'a d'objection ou d'autre proposition, je vais marquer le post #6 comme solution .
Mais on ne m'enlèvera pas le sentiment qu'il y a un bug qq part ..

 

[fanch55]

Whaaalouhhh, je ne peux pas marquer un de mes post comme solution !!!
@Dudu2, je marque ton dernier post comme solution, c'est pas la peine que qq d'autre se casse les méninges pour rien ..

 

[laurent950]

Bonsoir

How to delete all pictures in a range of cells?

ExtendOffice provides a comprehensive range of professional software solutions, enhancing productivity and efficiency for businesses worldwide.

www.extendoffice.com

Sub Efface()
' 1) #Data
    If Not [Tableau1].ListObject.DataBodyRange Is Nothing Then [Tableau1[#Data]].Delete
' 2) Picture
    Dim xPicRg As Range
    Dim xPic As Picture
    Dim xRg As Range
    Application.ScreenUpdating = False
    Set xRg = Range("Tableau1")
    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
    Next
    Application.ScreenUpdating = True
End Sub

 

[fanch55]

@laurent950
Salut laurent, merci
mais j'ai remarqué que si tu deletes le tableau avant les images, ces derniers ne sont plus dans le scope du tableau, normal ...

 

[Dudu2]

@fanch55,
Ta façon de faire est bien efficace. Un petit détail:
For Each Image In ActiveSheet.Pictures
Plutôt (par sécurité, on ne sait jamais)
For Each Image In [Tableau1].Parent.Pictures
Effectivement on ne peut soi-même se résoudre un problème

 

[laurent950]

Ca fonctionne dans les deux sens :

How to delete all pictures in a range of cells?

ExtendOffice provides a comprehensive range of professional software solutions, enhancing productivity and efficiency for businesses worldwide.

www.extendoffice.com

Excel: Les tableaux structurés en VBA

Excel: Les tableaux structurés en VBA

fauconnier.developpez.com

A ) deletes les images avant le tableau...

Sub EffaceBis()
    Dim xPicRg As Range
    Dim xPic As Picture
    Dim xRg As Range
    Application.ScreenUpdating = False
    Set xRg = Range("Tableau1")
' 1) Picture (Supression des images dans le tableau structuré)
    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
    Next
' 2) Data (Suppression des datas dans le tableau structuré)
    xRg.Delete
    Application.ScreenUpdating = True
End Sub

B ) deletes le tableau avant les images...

Sub EffaceTer()
    Dim xPicRg As Range
    Dim xPic As Picture
    Dim xRg As Range
    Application.ScreenUpdating = False
    Set xRg = Range("Tableau1")
' 2) Data (Suppression des datas dans le tableau structuré)
    xRg.Delete
' 1) Picture (Supression des images dans le tableau structuré)
    For Each xPic In ActiveSheet.Pictures
        Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
        If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
    Next
    Application.ScreenUpdating = True
End Sub

 

[fanch55]

@laurent950
Effectivement, test de tous tes codes ok ...
J'ai même interverti mon code, cela fonctionne aussi
Je ne sais pas pourquoi il ne m'a pas détecté l'intersect une fois (coz deboggage en cours peut-être) d'où la conclusion un peu hâtive ..

For Each Image In [Tableau1].Parent.Pictures

Effectivement, plus rigoureux donc plus précis