XL 2019 Récupérer des ligne de tableaux dans un tableau de "compilation"

[Meosus]

Bonjour,

Je cherche désespérément à faire une chose:

J'ai une feuille nommé "Paramètre" qui comporte x tableaux (piece1, piece2, piece3, ...)

J'ai une deuxième feuille nommé "BDC" qui sera un tableau de compilation.

Fonctionnement recherché (VBA ou non):

- Je cherche a sélectionner dans une liste le nom de la pièce, et que ça m’insère automatique toutes les lignes défini dans le tableau "Paramètre" de cette pièce. (exemple: Si le tableau Piece1 comporte 5 ligne il m’insères les 5 lignes a suivre)

merci d'avance

 

[Dudu2]

Bonjour,
A mettre dans le code de la feuille BDC.
(Voir message suivant)

 

[Dudu2]

Et pour que la mise sous forme de tableau que tu as utilisée suive, il faut non pas vider les cellules mais supprimer les lignes avec ce code:

Option Explicit

Private Const BDCCelluleNomPièce = "B7"
Private Const BDCColonneNomPièce = "B"
Private Const BDCColonneArticle = "C"
Private Const BDCColonneQuantité = "D"
Private Const BDCColonneImage = "E"

Private Const NomFeuilleParamètres = "Parametre"
Private Const ParamètresColonneNomPièce = "A"
Private Const ParamètresColonneArticle = "A"
Private Const ParamètresColonneQuantité = "B"
Private Const ParamètresColonneImage = "C"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Image As Shape
    Dim ParamètresDernièreLigne As Long
    Dim ParamètresLigne As Long
    Dim BDCLigne As Long
   
    Application.EnableEvents = False
    On Error GoTo Erreur

    'La cellule modifié n'est pas le nom de la pièce
    If Target.Address <> Me.Range(BDCCelluleNomPièce).Address Then GoTo FinSub
      
    With ThisWorkbook.Worksheets(NomFeuilleParamètres)
        ParamètresDernièreLigne = .Range(ParamètresColonneArticle & Rows.Count).End(xlUp).Row
       
        'Parcours de la colonne des noms de pièces dans la feuille Paramètres
        For ParamètresLigne = 1 To ParamètresDernièreLigne
            If .Range(ParamètresColonneNomPièce & ParamètresLigne).Value = Target.Value Then Exit For
        Next ParamètresLigne

        'Pas trouvé
        If ParamètresLigne > ParamètresDernièreLigne Then GoTo FinSub
       
        'Efface les données présentes
        BDCLigne = Me.Range(BDCCelluleNomPièce).Row
        Me.Range(BDCColonneArticle & BDCLigne).ClearContents
        Me.Range(BDCColonneQuantité & BDCLigne).ClearContents
        Set Image = ImageEnCellule(Me.Range(BDCColonneImage & BDCLigne))
        If Not Image Is Nothing Then Image.Delete
        BDCLigne = BDCLigne + 1
               
        Do While Not IsEmpty(Me.Range(BDCColonneArticle & BDCLigne))
            Set Image = ImageEnCellule(Me.Range(BDCColonneImage & BDCLigne))
            If Not Image Is Nothing Then Image.Delete
            Me.Range(BDCColonneNomPièce & BDCLigne & ":" & BDCColonneImage & BDCLigne).ListObject.ListRows(2).Delete
            Me.Rows(BDCLigne).Delete
        Loop
       
        'Ligne du 1er article
        ParamètresLigne = ParamètresLigne + 1
       
        'Copie les valeurs de la feuille Paramètres à la feuille BDC
        BDCLigne = Me.Range(BDCCelluleNomPièce).Row
       
        Do While Not IsEmpty(.Range(ParamètresColonneArticle & ParamètresLigne))
            Me.Range(BDCColonneArticle & BDCLigne).Value = .Range(ParamètresColonneArticle & ParamètresLigne).Value
            Me.Range(BDCColonneQuantité & BDCLigne).Value = .Range(ParamètresColonneQuantité & ParamètresLigne).Value
            Set Image = ImageEnCellule(.Range(ParamètresColonneImage & ParamètresLigne))
            If Not Image Is Nothing Then
                Image.Copy
                Me.Range(BDCColonneImage & BDCLigne).Select
                Me.Paste
            End If
            ParamètresLigne = ParamètresLigne + 1
            BDCLigne = BDCLigne + 1
        Loop
       
        Me.Range(BDCCelluleNomPièce).Offset(-1, 0).Select
    End With
    GoTo FinSub

Erreur:
    MsgBox "Erreur #" & Err.Number & " " & Err.Description
   
FinSub:
    On Error GoTo 0
    Application.EnableEvents = True
End Sub


Private Function ImageEnCellule(Cellule As Range) As Shape
    Dim oShape As Shape

    For Each oShape In Cellule.Parent.Shapes
        If oShape.Type = msoPicture Then
            If oShape.TopLeftCell.Address = Cellule.Address Then
                Set ImageEnCellule = oShape
                Exit Function
            End If
        End If
    Next
    Set ImageEnCellule = Nothing
End Function

 

[Meosus]

Merci @Dudu2!

C'est nikel. Pour que la fonction ce répète dans le tableau BDC (Piece 1, puis après on rajout une piece 2) ça marche que sur le premier il faut refaire une boucle d'analyse pour qu'il recherche les nouvelle ligne a insérer?

 

[Dudu2]

Je me rends compte que je n'ai pas utilisé en VBA les noms des colonnes du tableau Excel. Je n'ai pas l'expertise sur le sujet mais je vais essayer de l'acquérir.
S'il faut que l'opération puisse se répéter, ça devient un peu plus compliqué, car:
- Il faut ajouter une ligne vide en bas de la dernière pièce pour pouvoir ouvrir cette possibilité
- Lors d'un modification au milieu des pièces il faut ajuster le nombre de lignes
- Adapter la validation des données du choix de la pièce pour ne pas la faire apparaitre sur les lignes "articles" (meubles, objets)
- Enfin il faut laisser la possibilité de supprimer une pièce, avec un nom de pièce = "Supprimer" par exemple
Je vais essayer...

 

[Dudu2]

J'ai utilisé les éléments du Tableau Excel de la page BDC dans le VBA.
Je ne l'ai pas fait pour les tableaux en feuille Parametre, inutile car tableaux multiples.
Dans ta feuille définitive, vérifie bien la concordance des paramètres en Constantes dans le code de la feuille BDC par rapport au tableau (nom du tableau à vérifier dans le Gestionnaire de noms et de ses colonnes).
Pour gérer les remplacements et suppressions, il faut connaitre la valeur de Pièce avant modification. C'est fait grâce au Selection_Change() mais aussi grâce au Workbook_Open() qui force une sélection en A1 pour ne pas rater une sélection implicite de Pièce à l'ouverture du classeur échappant au Selection_Change(). Donc le Workbook_Open() fait partir du jeu.

P.S. Il est possible soit de supprimer une Pièce (supprimer le contenu de la cellule Pièce) soit de remplacer une Pièce par une autre (remplacer le contenu de la cellule Pièce). Il n'est pas possible d'insérer un Pièce ailleurs que sur la dernière ligne. Ça n'a rien de compliqué mais c'est le mode opératoire qui manque (à moins que tu en aies besoin et aies une idée de comment déclencher cette insertion).

 

[Dudu2]

Avec cette version la touche Insert est gérée pour insérer une Pièce au milieu de la liste.
Cela implique la création d'un Module car la fonction définie sur le OnKey ne peut pas être dans le code d'une feuille.
Il y a donc maintenant 3 composants du code:
- Workbook pour le Workbook_Open()
- Feuille BDC pour les Selection_Change() et le Change()
- Module Module_Fonctions pour le traitement de tous les cas

 

[Meosus]

Merci beaucoup @Dudu2 ! Tu es un champion! Je vais essayer tout ça!