XL 2016 [VBA] Répétition copier coller tableau et mise en forme

[Terreur]

Bien le bonjour à tout le monde,

Je dois créer une sorte d’outil excel permettant de générer une feuille de devis pour les clients. Le ficher contient un onglet « Produits » où l’on coche les produits que l’on désire. Le nombre de cases cochées est récupéré sous la forme d’une variable. Un fois les produits cochés le but est de créer le devis via l’onglet « Devis ». Celui-ci se compose d’une première partie de tableau commune qui est contenu dans l’onglet « Tableau taille » puis de X tableaux issus de l’onglet « Tableau catégorie ». La macro copie/colle la première partie de tableau dans l’onglet « Devis » puis dois copier/coller X fois le nombre de tableau (onglet « Tableau catégorie ») à la suite de cette première partie de tableau avec une col. Chaque tableau copier/coller doit avoir le nom du produit correspondant coché à la place de « Produit A ».

Ma macro copie/colle bien la première partie de tableau mais là où ça bloque c’est lors de la création des autres tableaux avec l’espacement d’une colonne et le nom à la place de « Produit A ». Ma macro ne copie colle pas x fois le tableau et je ne vois pas comment changer le nom de chaque tableau afin que la case produit cochée remplace le nom « Produit A ».


Je vous mets une copie d’écran du résultat que j’essaie d’avoir ainsi que mon fichier et le code ci-dessous.


Merci grandement d’avance de votre aide les amis.


Terreur


Sub Creation_Tableaux()

'Déclaration nbre de tableaux à créer
Dim Nbtableaux As Integer
Nbtableaux = Sheets("Produits").Range("F14").Value

'Nettoyage feuille avec tableaux
Sheets("Devis").Cells.Clear

'Copier première partie tableau
Sheets("Tableau Taille").Select
Range("A1:B33").Copy
Sheets("Devis").Select
Range("B2").Select
ActiveSheet.Paste
Columns("A:A").ColumnWidth = 2.14


'Copier les tableaux
For i = 1 To Nbtableaux

Sheets("Tableau catégorie").Select
Range("A1:C33").Copy
Sheets("Devis").Select
Range("B2").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 2).Select
ActiveSheet.Paste

Next

End Sub

 

[Yurperqod]

Bonjour le forum

Un essai pour la recopie des tableaux
J'ai utilisé la fonction Tableau
J'ai renommé tes tableaux existants en TAB_Taille et TAB_Cat
Est-ce que c'est un bon début ?

Sub Creation_Tableaux()
'Déclaration nbre de tableaux à créer
Dim DerCol As Long, i As Long
Dim Nbtableaux As Integer
Nbtableaux = Sheets("Produits").Range("F14").Value
Sheets("Devis").Cells.Clear
Range("TAB_Taille[#All]").Copy Sheets("Devis").Cells(4, "B")
Range("TAB_Cat[#All]").Copy Sheets("Devis").Cells(4, "D")
'Copier les tableaux
For i = 1 To Nbtableaux
DerCol = Sheets("Devis").Cells(4, Columns.Count).End(xlToLeft).Column
Range("TAB_Taille[#All]").Copy Sheets("Devis").Cells(4, "B").Offset(, DerCol - 1)
Range("TAB_Cat[#All]").Copy Sheets("Devis").Cells(4, "D").Offset(, DerCol - 1)
Next
End Sub

 

[Terreur]

Bonjour Yurperqod,

Merci de ton aide. J'ai essayé ta solution mais j'ai un code erreur 1004 "La méthode Clear de la classe Range a échoué." qui se produit au niveau de la déclaration des tableaux. Je ne vois malheureusement pas sur quoi cela bloque.

Merci de votre aide le forum.

 

[Yurperqod]

Bonjour le forum, bonjour Terreur

Terreur
J'ai testé sur ton fichier Excel sans erreur
Tu as bien nommé les tableaux comme j'ai fait ?

Comme je lance la macro, pour l'instant ca copie les tableaux

 

[Terreur]

Yurperqod j'ai bien nommé les tableaux comme tu l'as fait et le code erreur est là

 

[Yurperqod]

Il faut d'abord utiliser la fonction Tableau
(Insertion/Tableau) puis ensuite renommer les tableaux
Regarde ma copie d'écran et dans le gestionnaire de noms de ton Excel, on voit que les icones ne sont pas les mêmes

Voici la suite de mes tests

Sub Creation_Tableaux_V3()
Dim DerCol As Long
Dim i As Long
Sheets("Devis").Cells.Clear
For i = 7 To 12
If Sheets("Produits").Cells(i, "F") Then
DerCol = Sheets("Devis").Cells(4, Columns.Count).End(xlToLeft).Column
Range("TAB_Taille[#All]").Copy Sheets("Devis").Cells(4, "B").Offset(, DerCol - 1)
Range("TAB_Cat[#All]").Copy Sheets("Devis").Cells(4, "D").Offset(, DerCol - 1)
End If
Next
End Sub

Voila ce qu'on doit voir une fois corrigé en utilisant les Tableaux Excel

Je viens de modifier sur ton dernier fichier EXCEL et il n'y a plus de message d'erreur.

 

[Terreur]

Merci Yurperqod ! Ca marche ! Par contre par rapport à ma contrainte cela copie les deux tableau systématiquement alors que je ne voudrais que le TAB_Cat qui se copie plusieurs fois en fonction du nombre de cases =)

 

[Yurperqod]

Suite de mes tests

Sub Creation_Tableaux_V4()
Dim i As Long
Dim DebutCellule
DebutCellule = Array(4, 7, 10, 13, 16, 19)
Sheets("Devis").Cells.Clear
Range("TAB_Taille[#All]").Copy Sheets("Devis").Cells(4, "B")
For i = 7 To 12
If Sheets("Produits").Cells(i, "F") Then
Range("TAB_Cat[#All]").Copy Sheets("Devis").Cells(4, DebutCellule(i - 7))
'Pour faire des tests
Sheets("Devis").Cells(3, DebutCellule(i - 7)) = "Produits" & i
End If
Next
End Sub

Je continue à chercher comment récupérer le noms des produits dans les cases à cocher de la feuille Produits .

 

[Yurperqod]

Voila j'ai trouvé comment copier le nom des produits

Sub Creation_Tableaux_V5()
Dim cb As CheckBox
Dim i As Long
Dim DebutCellule
DebutCellule = Array(4, 7, 10, 13, 16, 19)
i = 7
Sheets("Devis").Cells.Clear
Range("TAB_Taille[#All]").Copy Sheets("Devis").Cells(4, "B")
For Each cb In Sheets("Produits").CheckBoxes
If cb.Value = xlOn Then
Range("TAB_Cat[#All]").Copy Sheets("Devis").Cells(4, DebutCellule(i - 7))
Sheets("Devis").Cells(3, DebutCellule(i - 7)) = cb.Caption
i = i + 1
End If
Next cb
End Sub

 

[Terreur]

Merci énormément Yurperqod =) Je regarde ça de suite

 

[Terreur]

Ca fonctionne très bien =) Un grand merci à toi !