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

Terreur

XLDnaute Nouveau
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
 

Pièces jointes

  • Outil essai devis.xlsm
    29.5 KB · Affichages: 32
  • Résultat voulu.png
    Résultat voulu.png
    105.9 KB · Affichages: 63

Yurperqod

XLDnaute Occasionnel
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 ?
VB:
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

XLDnaute Nouveau
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

XLDnaute Occasionnel
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 ?
Tableaux.gif
Comme je lance la macro, pour l'instant ca copie les tableaux
 

Yurperqod

XLDnaute Occasionnel
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
VB:
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
Tableaux2.gif
Je viens de modifier sur ton dernier fichier EXCEL et il n'y a plus de message d'erreur.
 
Dernière édition:

Yurperqod

XLDnaute Occasionnel
Suite de mes tests
VB:
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

XLDnaute Occasionnel
Voila j'ai trouvé comment copier le nom des produits
VB:
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
 

Discussions similaires

Réponses
15
Affichages
425