XL 2019 Supprimer/ajouter une sélection d'image avec VBA

[halogi]

bonjour, J'ai un fichier sur lequel

1- Dans la feuille "Saisie Table" je choisi ma table dans la liste déroulante.
2- Le choix de la liste déroulante induit de copier/coller la feuille qui porte le meme nom sur la feuille "saisie table"
3- Lors que je fais un autre choix dans la liste déroulante, les images du tableau et l'image du bas de page reste fixes et la plage de copie de l'onglet correspondant change.


Voici le fichier que j'ai pour l'instant.. qui ne fonctionne pas..

Est-ce que quelqu'un pourrait m'apporter la lumière au bout du tunnel svp ?

 

[AtTheOne]

bonsoir à tous
Oups ! Tu as oublier de joindre le fichier !
Amicalement
Alain

 

[halogi]

bonsoir, Oh mince, le voici

 

[sousou]

t'es sur que c'est le bon fichier?

 

[AtTheOne]

Bonjour,
Effectivement le fichier que tu as joint ne semble pas correspondre à ta demande initiale.
Mais pour ce qui est expliqué dans ce fichier , la pièce jointe fait le boulot.

Sub Compiler()

Const NbCell As Byte = 6 'Nbre de cellules à recopier

Dim Rg_Test As Range, Wsh As Worksheet, Lo As ListObject, Tb

'Cible :
Set Wsh = ThisWorkbook.Worksheets("Synthèse")  'Feuille cible
Set Lo = Wsh.ListObjects(1)                    'Tableau structuré cible

'Source : On demande de sélectionner la cellule qui contient le nom du test (ici "Test 2")
On Error Resume Next
Set Rg_Test = Application.InputBox(Title:="Recopie d'un test dans la synthèse", Prompt:="Selectionner la cellule qui contient le nom du Test (Test x)", Type:=8).Resize(, NbCell)
On Error GoTo 0
If Rg_Test Is Nothing Then Exit Sub
 
'On copie les valeurs et on va sur la cible
Tb = Rg_Test.Value
With Lo
     .Range.Offset(.Range.Rows.Count).Resize(1).Value = Tb
     Application.Goto .Range.Offset(.Range.Rows.Count - 1).Resize(1, 1)
End With

 
End Sub

Amicalement
Alain

 

[halogi]

t'es sur que c'est le bon fichier?

Je suis tête en l'air pardon ce n'était pas le bon fichier.. Le voici

 

[halogi]

Bonjour,
Effectivement le fichier que tu as joint ne semble pas correspondre à ta demande initiale.
Mais pour ce qui est expliqué dans ce fichier , la pièce jointe fait le boulot.

Sub Compiler()

Const NbCell As Byte = 6 'Nbre de cellules à recopier

Dim Rg_Test As Range, Wsh As Worksheet, Lo As ListObject, Tb

'Cible :
Set Wsh = ThisWorkbook.Worksheets("Synthèse")  'Feuille cible
Set Lo = Wsh.ListObjects(1)                    'Tableau structuré cible

'Source : On demande de sélectionner la cellule qui contient le nom du test (ici "Test 2")
On Error Resume Next
Set Rg_Test = Application.InputBox(Title:="Recopie d'un test dans la synthèse", Prompt:="Selectionner la cellule qui contient le nom du Test (Test x)", Type:=8).Resize(, NbCell)
On Error GoTo 0
If Rg_Test Is Nothing Then Exit Sub
 
'On copie les valeurs et on va sur la cible
Tb = Rg_Test.Value
With Lo
     .Range.Offset(.Range.Rows.Count).Resize(1).Value = Tb
     Application.Goto .Range.Offset(.Range.Rows.Count - 1).Resize(1, 1)
End With

 
End Sub

Amicalement
Alain

Vraiment désolée, sousou m'a fait remarquer que je n'avais pas joint le bon fichier.. Merci pour votre aide !

 

[AtTheOne]

Salut @halogi

Je suis tête en l'air pardon ce n'était pas le bon fichier.. Le voici

Il est où le fichier ? (on va y arriver !)
Amicalement
Alain

 

[halogi]

Salut @halogi

Il est où le fichier ? (on va y arriver !)
Amicalement
Alain

Le fichier était trop volumineux, vous pouvez le télécharger sur cette adresse : https://www.cjoint.com/c/LBencteW0UL

 

[AtTheOne]

Re-Bonjour

Je crois que je ne comprends pas bien ta problématique :
Sur le fichier joint, quand on sélectionne une table dans l'onglet saisie table, celle-ci remplace bien celle qui était sélectionnée auparavant, le tableau de choix et l'image du bas restant inchangés !
N'est-ce-pas ce que tu veux ?

Alain

 

[AtTheOne]

Re-Re-bonjour à tous
Est-ce-que ton problème ne vient pas de la "Drop Down x" qui change de nom ?
Essaie avec ce code :

Private Sub Worksheet_Change(ByVal Target As Range)
   
     Const Plage = "A1:L26"   'Plage source à recopier
     Const Cible = "A13"      'Cellule cible
     Const Origine = "L5"     'Cellule contenant le choix de table
   
     Dim Ws As Worksheet
     Dim Sh As String
     Dim shp As Shape
     Dim Rg As Range
   
     If Not Application.Intersect(Target, Range(Origine)) Is Nothing Then
          Application.EnableEvents = False

          For Each shp In Me.Shapes
               Set Rg = Nothing
               'pour les objets sans TopLeftCell (les "drop down")
               On Error Resume Next
               Set Rg = shp.TopLeftCell
               On Error GoTo 0
             
               If Not Rg Is Nothing Then
                    'supprimer les formes situées dans la zone Cible
                    If Not Application.Intersect(shp.TopLeftCell, Range(Cible).Range(Plage)) Is Nothing Then
                         shp.Delete
                    End If
               End If
          Next
         
          'Effacer la zone cible
          Me.Range(Cible).Range(Plage).Clear
         
          'Recopier la zone source
          Sh = Target.Value
          Worksheets(Sh).Range(Plage).Copy Me.Range(Cible).Range(Plage)
         
          Application.EnableEvents = True
     End If

End Sub

A bientôt
Alain