Sauver nouveau fichier dans un dossier dédié
Bonjour,
Voici la situation: Je dispose d'un fichier comprenant 3 onglets
- Une feuille comprenant un bouton pour lancer la macro
- Une base de donnée
- Un "template" de questionnaire
J'ai un code qui pour chaque ligne d'une colonne (colonne B, account number) dans la base de donnée génère un questionnaire dans un dossier que je crée spécialement.
Chaque questionnaire généré porte le nom de la ligne correspondante dans la colonne B.
J'aimerais qu'en plus de sauver tous les questionnaires dans un dossier, il les sauve dans un dossier dédié. Par exemple, sur la ligne 2:
Donc : accountnumber.xlsx sauvé dans le dossier accountnumber
J'espère que c'est compréhensible !
Pouvez-vous m'aider?
Merci !
Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set wb = ActiveWorkbook
Path = wb.Path
Set sh2 = wb.Sheets("Data")
lr = sh2.Cells(Rows.Count, "B").End(xlUp).Row
Set tbl = sh2.ListObjects("Table2") 'définir sous forme de format tableau dans excel au préalable
For x = 1 To tbl.Range.Rows.Count - 1 'commence sur la ligne 1
Sheets("Template").Copy
Set wb_temp = ActiveWorkbook
Set sh3 = wb_temp.Sheets("Template")
For y = 2 To tbl.Range.Columns.Count 'commence sur la colonne 2
Set celltemp = Range("B:B").Find(tbl.HeaderRowRange(y).Value, LookIn:=xlValues, Lookat:=xlWhole) 'cherche la valeur exacte dans la colonne Y depuis la range B
If Not celltemp Is Nothing Then
celltemp.Offset(0, 1) = tbl.DataBodyRange(x, y).Value 'cherche dans le body du tableau
If celltemp = "Account number" Then
c = celltemp.Offset(0, 1).Value
'prendre le account number en valeur pour nommer le fichier
End If
End If
Next
If Dir(Path & "\Questionnaires", vbDirectory) <> "" Then
wb_temp.SaveAs Path & "\Questionnaires\" & c & ".xlsx"
wb_temp.Close
Else
FSO.CreateFolder (Path & "\Questionnaires")
wb_temp.SaveAs Path & "\Questionnaires\" & c & ".xlsx"
wb_temp.Close
End If
Next
End Sub
bonsoir
un essai convient-il ??
fred
Sub create()
Dim wb As Workbook, sh1 As Worksheet, lr As Long, rng As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set wb = ActiveWorkbook
Path = wb.Path
Set sh2 = wb.Sheets("Data")
lr = sh2.Cells(Rows.Count, "B").End(xlUp).Row
Set tbl = sh2.ListObjects("Table2") 'définir sous forme de format tableau dans excel au préalable
For x = 1 To tbl.Range.Rows.Count - 1 'commence sur la ligne 1
Sheets("Template").Copy
Set wb_temp = ActiveWorkbook
Set sh3 = wb_temp.Sheets("Template")
For y = 2 To tbl.Range.Columns.Count 'commence sur la colonne 2
Set celltemp = Range("B:B").Find(tbl.HeaderRowRange(y).Value, LookIn:=xlValues, Lookat:=xlWhole) 'cherche la valeur exacte dans la colonne Y depuis la range B
If Not celltemp Is Nothing Then
celltemp.Offset(0, 1) = tbl.DataBodyRange(x, y).Value 'cherche dans le body du tableau
If celltemp = "Account number" Then
c = celltemp.Offset(0, 1).Value
'prendre le account number en valeur pour nommer le fichier
End If
End If
Next
If x = 1 Then
If Dir(Path & "\Questionnaires", vbDirectory) <> "" Then FSO.CreateFolder (Path & "\Questionnaires")
End If
FSO.CreateFolder (Path & "\Questionnaires\" & c)
wb_temp.SaveAs Path & "\Questionnaires\" & c & "\" & c & ".xlsx"
wb_temp.Close
Next
End Sub
Bonjour,
Merci pour votre réponse.
Malheureusement, non cela ne fonctionne pas. Le message d'erreur "Path not found" s'affiche lorsque le premier "template" est généré. J'ai l'impression qu'il ne crée pas le dossier et que du coup il ne peut pas le sauver dedans.
Une idée de résolution?
Merci.
l
bonjour
merci de fournir un fichier test avec 2/3 lignes pour voir
fred
Edit :
petite correction remplacer la ligne
If Dir(Path & "\Questionnaires", vbDirectory)<> "" Then FSO.CreateFolder (Path & "\Questionnaires")
par
If Dir(Path & "\Questionnaires", vbDirectory) = "" Then FSO.CreateFolder (Path & "\Questionnaires")
fred
Bonjour,
Cela fonctionne parfaitement. Merci Fred !