Aide VBA - Dupliquer Onglets via un tableau structuré
Bonjour à tous !
Je suis en train de travailler sur un tableau à destination d'un groupe de travail qui devra renseigner des informations pour chacun des clients.
A cet effet, je souhaite dupliquer un onglet ("Modèle") du tableau ci-joint afin d'en créer un pour chaque client. J'ai déjà trouvé des bouts de code qui permettent de dupliquer les onglets mais étant encore novice en la matière, je n'arrive pas bien à l'adapter à mon cas.
En effet, lorsque je regarde les macros proposées, la liste qui permet de renommer chaque onglet dupliqué se trouve dans une plage de type A:A avec quelque chose du style .End(xlUp).Row (ce qui à mon sens permet d'aller jusqu'au bout des lignes). Cependant avec mon fichier je ne souhaite pas cibler une colonne (A, B...) qui risquerai de contenir d'autres données. Je souhaite simplement utiliser les plages renommées (NumClient, NomClient..) afin d'être certain de ne prendre que les bonnes données.
Voici le code que j'ai trouvé mais qui pour l'instant "bug" à chaque modification de ma part.
Public Function FeuilleExiste(FeuilleAVerifier As String) As Boolean
On Error GoTo SiErreur
Dim Feuille As Worksheet
FeuilleExiste = False
For Each Feuille In Worksheets
If Feuille.Name = FeuilleAVerifier Then
FeuilleExiste = True
Exit Function
End If
Next Feuille
Exit Function
SiErreur:
MsgBox "Une erreur s'est produite..."
FeuilleExiste = CVErr(xlErrNA)
End Function
Sub dupliquer()
Dim nom As String
Set Ws = Worksheets("Sommaire")
nbcc = Ws.Range("D1").Value
For I = 1 To Ws.Range("NumSoc").End(xlUp).Row
nom = Ws.Range("NumSoc").Value
If FeuilleExiste(nom) = False Then
Sheets("Modèle").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = nom
End If
Next
End Sub
Ca serait top si quelqu'un pouvait m'indiquer ce que je dois changer/déclarer/modifier afin que cela fonctionne.
D'avance merci !
Sam
Bonjour,
Un proposition https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466 qui te permettra de scinder ton fichier en autant de fichier qu'il y a de valeurs différente dans une colonne quelconque. En retour il te permettra aussi de collecter les fichiers renseignés.
Bonjour Steelson,
Merci pour ta réponse. Etant novice je t'avoue que le code me file un peu le tournis
Après, le but était vraiment de pouvoir dupliquer l'onglet "Modèle" dans le même tableau en lui attribuant juste un nom différent (cf. la liste des numéros client)
Mais je garde tout de même ta proposition pour mon acculturation et un éventuel futur projet. Cela m'aide beaucoup de décortiquer les différentes propositions des uns et des autres.
Du coup si quelqu'un à une solution, je suis toujours preneur ^^
J'ai répondu un peu vite ... j'ai compris que tu voulais dupliquer des fiches.
Donc voici un premier jet vite fait ... je vais l'améliorer d'ici demain mais il est déjà fonctionnel. Un fichier est créé par client. Il faut juste choisir le répertoire dans lequel stocker ces fichiers.
Sub creerfiches()
Dim bdd As Worksheet
Dim fiche As Worksheet
' définitions pour fichier cible
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set bdd = Sheets("BDD")
Set fiche = Sheets("Modèle")
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
MonRepertoire = Repertoire.SelectedItems(1)
'Application.ScreenUpdating = false
Set xl = CreateObject("Excel.Application")
xl.SheetsInNewWorkbook = 1 ' On défini le nombre d'onglets (ici 1 seul)
For i = 5 To bdd.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To 4
fiche.Range(bdd.Cells(1, j)) = bdd.Cells(i, j)
Next
fiche.Cells.Copy
Set wb = xl.Workbooks.Add ' On ajoute un classeur
xl.Visible = True
Set ws = wb.Worksheets(1) ' On crée l'objet onglet dans le nouveau classeur créé
Application.Wait (Now + TimeValue("0:00:02"))
ws.Paste
' sauvegared du fichier
wb.SaveAs (MonRepertoire & "\" & bdd.Cells(i, 2) & " " & Format(Now(), "yyyy-mm-dd") & " " & nomFichier)
Next
'xl.SheetsInNewWorkbook = 3 ' On remet la propriété de l'application à 3 (par défaut)
xl.Quit
'Application.ScreenUpdating = True
MsgBox "Terminé, fiches sauvegardées sous """ & MonRepertoire & "\" & """ !"
End Sub
Haha ! Effectivement tu codes bien au delà de mes connaissances ^^ Et ça a l'air super !
Si tu comptes revoir le code pourrais-tu faire en sorte que l'onglet "Modèle" soit dupliqué et renommé (autant de fois que nécessaire) à la suite des autres ? Plutôt que de proposer un enregistrement de chaque onglet comme un nouveau classeur ?
L'idée en fait (c'est ptet moi qui ne m'exprime pas bien ^^) serait de dupliquer "Modèle" en fonction de la liste des clients présente dans le tableau de l'onglet "BDD". Et éventuellement (et là ça serait du luxe) rapatrier le nom et le numéro dans chaque onglet créé.
En tout cas, merci pour ta réactivité et ton aide qui me font, j'en suis sur, progresser dans ma compréhension de ces fonctions.
A plus.
Sam
Pas de soucis (je ferai les 2 car je pense que la duplication sur des fichiers séparés est utile quand on envoie ensuite par mail un questionnaire).
Dupliquer l'onglet est plus simple !
Sub creerfiches()
Dim bdd As Worksheet, modele As Worksheet, fiche As Worksheet, tbl As ListObject
Set bdd = Sheets("BDD")
Set modele = Sheets("Modèle")
Set tbl = bdd.ListObjects(1)
col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données
For i = 1 To tbl.ListRows.Count
modele.Cells.Copy
Set fiche = Sheets.Add(After:=Sheets(Sheets.Count))
fiche.Paste
On Error Resume Next ' au cas où la fiche existerait déjà !
fiche.Name = tbl.DataBodyRange.Cells(i, 1)
On Error GoTo 0
For j = 1 To tbl.ListColumns.Count
' position dans la fiche donnée en ligne 1 de bdd
If bdd.Cells(1, j + col - 1) <> "" Then fiche.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
Next
Next
MsgBox "Terminé !"
End Sub
La position des données dans la fiche est donnée en première ligne au-dessus du tableau.
Bonjour,
@Steelson,
Ma vision matinale de la chose.
Public Sub CreateSheets()
Dim lo As ListObject, ws As Worksheet
Dim arrValues, sheetName As String
Dim I As Long
Set lo = Range("T_BDD").ListObject
For I = 1 To lo.ListRows.Count
sheetName = lo.ListRows(I).Range.Cells(1).Value
On Error Resume Next
Set ws = Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then
arrValues = lo.ListRows(I).Range.Value
With Worksheets("Modèle")
.Cells(4, 3).Resize(3).Value = Application.Transpose(arrValues)
.Copy after:=Worksheets(Worksheets.Count)
End With
ActiveSheet.Name = sheetName
End If
Next
Worksheets("Modèle").Cells(4, 3).Resize(3).Value = ""
Worksheets(lo.Parent.Name).Activate
End Sub
Cdlt.
Bonjour Jean-Eric,
- je voulais pour ma part paramétrer les données et les "ranger" dans la fiche selon un ordre qui peut-être défini au préalable, sans forcément en reprendre tous les termes de la BdD
- dans tous les cas, je suis plus "axé" vers une solution multi-fichiers qui peut être envoyée comme un questionnaire pré-rempli, ce que je mettrai dans les applications (c'était un sujet que je mijotais)
Bien sûr ta version est très intéressante.
Bonjour à tous les deux !
J'ai vraiment de la chance, vos réponses rapides sont d'une qualité remarquable. Ca fait plaisir quand on débute de pouvoir être aidé de la sorte.
Je cherchais désespérément à "appeler" le tableau créé sur la feuille BDD et à en utiliser les lignes. C'était la partie lo et .ListObject qui me manquait pour exploiter ma base. Merci pour ça. J'avoue qu'il va me falloir encore comprendre une partie de ce que vous avez écrit pour que je puisse le refaire par moi-même la prochaine fois, mais ça, c'est mon problème ^^ (et les commentaires aident déjà)
Je suis toujours preneur (à vos heures perdues, aucune urgence ici) d'une version qui pourrait créer des fichiers distincts comme propose @Steelson. Sur ce document il n'y avait pas une forte utilité car je le transmet à une personne d'un autre service qui aura plus facile de travailler sur le même classeur mais j'ai déjà eu des demandes où je dois être en capacité de produire un classeur par "fiche" et ce projet me ferait gagner un temps considérable.
Du coup encore merci de votre aide, vous êtes au top !
Sam
Version fichiers distincts
Option Explicit
Sub creerfiches()
Dim bdd As Worksheet, modele As Worksheet, fiche As Worksheet, tbl As ListObject, i%, j%, col%
Dim Repertoire, monRepertoire As Variant
Set bdd = Sheets("BDD")
Set modele = Sheets("Modèle")
Set tbl = bdd.ListObjects(1)
col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données
' définitions pour fichier cible
Dim xl As Excel.Application, wb As Workbook, ws As Worksheet
' choix du répertoire de stockage
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
monRepertoire = Repertoire.SelectedItems(1)
Set xl = CreateObject("Excel.Application")
For i = 1 To tbl.ListRows.Count
For j = 1 To tbl.ListColumns.Count
' position dans la fiche donnée en ligne 1 de bdd
If bdd.Cells(1, j + col - 1) <> "" Then modele.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
Next
modele.Cells.Copy
Set wb = xl.Workbooks.Add ' On ajoute un classeur
xl.Visible = True
Set ws = wb.Worksheets(1) ' On crée l'objet onglet dans le nouveau classeur créé
Application.Wait (Now + TimeValue("0:00:02"))
ws.Paste
' sauvegarde du fichier
wb.SaveAs (monRepertoire & "\" & tbl.DataBodyRange.Cells(i, 1))
Next
xl.Quit
Application.CutCopyMode = False
MsgBox "Terminé, fiches sauvegardées sous """ & monRepertoire & "\" & """ !"
End Sub
Version qui permet de mieux contrôler la mise en forme des fiches générées ...
Il faut mettre un modèle appelé Fiches.xlsx
dans le même dossier que le fichier comportant la base de données.
Option Explicit
Sub creerfiches()
Dim bdd As Worksheet, fiche As Worksheet, tbl As ListObject, i%, j%, col%, wb As Workbook
Dim Repertoire, monRepertoire As Variant
Set bdd = Sheets("BDD")
Set tbl = bdd.ListObjects(1)
col = tbl.DataBodyRange.Cells(1, 1).Column ' position du tableau de données
' choix du répertoire de stockage
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
monRepertoire = Repertoire.SelectedItems(1)
Application.ScreenUpdating = False
For i = 1 To tbl.ListRows.Count
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Fiche.xlsx")
Set fiche = wb.Sheets(1)
For j = 1 To tbl.ListColumns.Count
' position dans la fiche donnée en ligne 1 de bdd
If bdd.Cells(1, j + col - 1) <> "" Then fiche.Range(bdd.Cells(1, j + col - 1)) = tbl.DataBodyRange.Cells(i, j)
Next
wb.SaveAs (monRepertoire & "\" & tbl.DataBodyRange.Cells(i, 1))
wb.Close
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Terminé, fiches sauvegardées sous """ & monRepertoire & "\" & """ !"
End Sub
Bonjour @Steelson
Eh ben, si avec tout ça je n'ai pas de quoi réaliser mon projet ^^
Merci pour tout le travail fourni, c'est hyper appréciable ! Et j'avoue que l'idée de bosser avec un modèle a part semble ouvrir encore plus le champ des possibles.
Je pense que je peux clore le sujet.