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 !

Rechercher des sujets similaires à "sauver nouveau fichier dossier dedie"