Sauver nouveau fichier dans un dossier dédié Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
l
lejack02
Membre habitué
Membre habitué
Messages : 59
Inscrit le : 19 novembre 2016
Version d'Excel : 2013

Message par lejack02 » 23 décembre 2016, 16:13

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

Avatar du membre
fred2406
Membre impliqué
Membre impliqué
Messages : 2'040
Appréciations reçues : 36
Inscrit le : 13 mai 2014
Version d'Excel : O365Pro-2019-2011MAC
Version de Calc : 6.3

Message par fred2406 » 23 décembre 2016, 18:33

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
Je ne réponds pas aux M.P. non sollicités.
Ne pas oublier :
:btres:
Fred :O-O:
l
lejack02
Membre habitué
Membre habitué
Messages : 59
Inscrit le : 19 novembre 2016
Version d'Excel : 2013

Message par lejack02 » 27 décembre 2016, 09:32

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
Modifié en dernier par lejack02 le 27 décembre 2016, 12:04, modifié 1 fois.
Avatar du membre
fred2406
Membre impliqué
Membre impliqué
Messages : 2'040
Appréciations reçues : 36
Inscrit le : 13 mai 2014
Version d'Excel : O365Pro-2019-2011MAC
Version de Calc : 6.3

Message par fred2406 » 27 décembre 2016, 11:44

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)[surligner]<>[/surligner] "" Then FSO.CreateFolder (Path & "\Questionnaires")
par
   If Dir(Path & "\Questionnaires", vbDirectory) [surligner]=[/surligner] "" Then FSO.CreateFolder (Path & "\Questionnaires")
fred
Je ne réponds pas aux M.P. non sollicités.
Ne pas oublier :
:btres:
Fred :O-O:
l
lejack02
Membre habitué
Membre habitué
Messages : 59
Inscrit le : 19 novembre 2016
Version d'Excel : 2013

Message par lejack02 » 27 décembre 2016, 16:02

Bonjour,

Cela fonctionne parfaitement. Merci Fred !
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message