créer un dossier puis un fichier dans le dossier via VBA

J

jujunexcelpas

XLDnaute Nouveau
Bonjour le forum,
je suis dans une impasse, avec votre aide une macro a été créée et je souhaiterai ajouter une étape pour son bon fonctionnement!
la macro crée un fichier dans un dossier cible, et je souhaiterai que celle ci crée un dossier nominatif dans lequel ira le fichier excel! je sais créer le dossier, je sais créer le fichier mais je n'arrive à mettre le fichier dans le dossier! je vous fais parvenir la macro, si vous pouviez m'aider ça résoudrai un long projet !

Option Explicit
Dim Mess As Integer, r As String
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim xshcherchee As Worksheet
Sub Sauvegarde_Modele()
'CREER UN DOSSIER
r = Feuil23.[C2]
If Dir("C:\Users\coach\dropbox\Musculation\" & r, vbDirectory) = "" Then _
MkDir "C:\Users\coach\dropbox\Musculation\" & r
' CREER UN CLASSEUR dans le dossier
Application.ScreenUpdating = False
xnomfic = Range("C2"): ficd = xnomfic & ".xlsx": xcell = Range("F2"): xnomsh = Replace(xcell, "/", "")

' Contrôle de l'existence du fichier ou classeur
If FichierExiste("C:\Users\coach\dropbox\Musculation\" & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
' ------------------------------------------------------------------------------------------------------------------
' Le classeur existe - On recherche si la feuille existe
Workbooks.Open ("C:\Users\coach\dropbox\Musculation\" & ficd): Workbooks(ficd).Activate ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
For Each xshcherchee In Worksheets
If xshcherchee.Name = xnomsh Then
MsgBox "SAUVEGARDE IMPOSSIBLE - Cette feuille " & xnomsh & " existe déjà dans le classeur du joueur : " & xnomfic & ".", vbCritical
ActiveWorkbook.Save: ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
Exit Sub
End If
Next

' Le classeur existe - On ajoute la feuille
Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A:p").Copy
With ActiveWorkbook.Sheets(xnomsh)
.Range("A:p").PasteSpecial Paste:=xlPasteValues
.Range("A:p").PasteSpecial Paste:=xlPasteFormats
.Range("A:p").PasteSpecial Paste:=xlPasteFormulas
End With
Application.CutCopyMode = False
MsgBox "Sauvegarde effectuée."
'ActiveWorkbook.SaveAs Filename:="C:\Users\coach\dropbox\Musculation\" & xnomfic & ".xlsx" ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Save
ActiveWorkbook.Close
Workbooks("Musculation.xlsm").Sheets("Modele").Activate
' ------------------------------------------------------------------------------------------------------------------
Else
'___________________________________________________________________________________________________________________
' Création du fichier ou classeur et copie de la feuille modele
Workbooks.Add
Workbooks("Musculation.xlsm").Sheets("Modele").Range("A:p").Copy
With ActiveWorkbook.Sheets("Feuil1")
.Range("A:p").PasteSpecial Paste:=xlPasteValues
.Range("A:p").PasteSpecial Paste:=xlPasteFormats
.Range("A:p").PasteSpecial Paste:=xlPasteFormulas
End With
Application.CutCopyMode = False
ActiveSheet.Name = xnomsh
ActiveWorkbook.SaveAs Filename:="C:\Users\coach\dropbox\Musculation\" & xnomfic & ".xlsx" ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
ActiveWorkbook.Close
MsgBox "Sauvegarde effectuée."
End If
'___________________________________________________________________________________________________________________
Application.ScreenUpdating = True
End Sub

Function FichierExiste(ficd) As Boolean
FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function

Cordialement
jujunexcelpas
 
Trier par date Trier par votes
Paf

Paf

XLDnaute Barbatruc
Re : créer un dossier puis un fichier dans le dossier via VBA

Bonjour

mais je n'arrive à mettre le fichier dans le dossier!
Cliquez pour agrandir...
Pas tout compris au soucis puisque, dans le cas d'un nouveau classeur, le code l'enregistre bien dans le répertoire.
(mais, a priori il manque un End If)

Y a t-il un message d'erreur ? sur quelle ligne s'arrête le code à l'exécution ?

A+ de précisions
 
Vote positif 0 Vote négatif
J

jujunexcelpas

XLDnaute Nouveau
Re : créer un dossier puis un fichier dans le dossier via VBA

bonjour Paf, bbb38, et le forum,
pour le code je n'ai pas de message d'erreur simplement le fait que le dossier et le classeur s'enregistre côte à côte dans le dossier musculation!
j'ai un peu avancé sur le code en question cependant je me retrouve avec un problème j'ai 2 macros sur 2 dossiers différents qui doivent s'enregistrer de la même façon dans le dossier créé
le premier code c'est celui que je t'ai envoyé dans le premier message mais cette fois il fonctionne comme je le souhaite:

Code: 
Option Explicit
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim Chemin2 As String
Dim sDos As String
Dim xshcherchee As Worksheet
Function FichierExiste(ficd) As Boolean
    FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
Function DossierExiste(sDos) As Boolean
    DossierExiste = Dir(sDos) <> "" And sDos <> ""
End Function
Sub Enregistrer6X35()

     ' CREER UN DOSSIER
      Application.ScreenUpdating = False
      Chemin2 = "C:\users\coach\dropbox\joueurs\"
      sDos = Workbooks("6X35.xlsm").Sheets("Modele").Range("M2")
      xnomfic = Range("M2"): ficd = xnomfic & " 6X35.xlsx"

    If DossierExiste(Chemin2 & sDos) = "Vrai" Then    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
    
    ' CREER UN CLASSEUR
    Application.ScreenUpdating = False
    xnomfic = Range("M2"): ficd = xnomfic & " 6X35.xlsx"
    
[COLOR="#00FF00"]    ' Création du fichier ou classeur et copie de la feuille modele
[/COLOR]        Workbooks.Add
        Workbooks("6X35.xlsm").Sheets("Modele").Range("$A$1:$L$3").Copy
            With ActiveWorkbook.Sheets("Feuil1")
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteValues
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteFormats
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteFormulas
            End With
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:=Chemin2 & sDos & "\" & xnomfic & " 6X35.xlsx" ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ActiveWorkbook.Close
        MsgBox "Sauvegarde effectuée."
        '___________________________________________________________________________________________________________________
    Application.ScreenUpdating = True

    Else

    
  ' Contrôle de l'existence du fichier ou classeur
    If FichierExiste(Chemin2 & sDos & "\" & ficd) = "Vrai" Then ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE

        For Each xshcherchee In Worksheets
                If xshcherchee.Name = xnomsh Then
                    MsgBox "SAUVEGARDE IMPOSSIBLE - Cette feuille " & xnomsh & " existe déjà dans le classeur du joueur : " & xnomfic & ".", vbCritical
                    ActiveWorkbook.Save: ActiveWorkbook.Close
                    Workbooks("6X35.xlsm").Sheets("Modele").Activate
                    Exit Sub
                End If
            Next
            
        ' Le classeur existe - On insert le nouveau tableau
        Sheets("Modele").Range("$A$1:$L$3").Copy
        Workbooks.Open (Chemin2 & sDos & "\" & ficd): Workbooks(ficd).Sheets("Feuil1").Rows.Insert
        'ActiveWorkbook.SaveAs Filename:="C:\users\coach\dropbox\Tests\" & xnomfic & ".xlsx"    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        MsgBox "Sauvegarde effectuée."
        
          ' ------------------------------------------------------------------------------------------------------------------
    Else
    
    ' Création d'un dossier
  
  MkDir Chemin2 & sDos
        '___________________________________________________________________________________________________________________
        ' Création du fichier ou classeur et copie de la feuille modele
        Workbooks.Add
        Workbooks("6X35.xlsm").Sheets("Modele").Range("$A$1:$L$3").Copy
            With ActiveWorkbook.Sheets("Feuil1")
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteValues
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteFormats
                .Range("$A$1:$L$3").PasteSpecial Paste:=xlPasteFormulas
            End With
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:=Chemin2 & sDos & "\" & xnomfic & " 6X35.xlsx" ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ActiveWorkbook.Close
        MsgBox "Sauvegarde effectuée."
        '___________________________________________________________________________________________________________________
    Application.ScreenUpdating = True
End If


End If

End Sub

Cependant le deuxième code qui devrait être identique au précédent ne fonctionne pas , aucun message d'erreur, bref aucune action:
Code: 
Option Explicit
Dim xnomfic As String, ficd As String, xcell As String, xnomsh As Variant
Dim Chemin2 As String
Dim sDos As String
Dim xshcherchee As Worksheet
Function FichierExiste(ficd) As Boolean
    FichierExiste = Dir(ficd) <> "" And ficd <> ""
End Function
Function DossierExiste(sDos) As Boolean
    DossierExiste = Dir(sDos) <> "" And sDos <> ""
End Function
Sub Sauvegarde_Modele()
    'CREER UN DOSSIER
       Application.ScreenUpdating = False
       Chemin2 = "C:\users\coach\dropbox\joueurs\"
       sDos = Workbooks("Musculation.xlsm").Sheets("Modele").Range("C2")
       xnomfic = Range("C2"): ficd = xnomfic & " Musculation.xlsx"

    If DossierExiste(Chemin2 & sDos) = "Vrai" Then    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
    
    ' CREER UN CLASSEUR
    Application.ScreenUpdating = False
    xnomfic = Range("C2"): ficd = xnomfic & " Musculation.xlsx"
    
    ' Contrôle de l'existence du fichier ou classeur
    If FichierExiste(Chemin2 & sDos & "\" & ficd) = "Vrai" Then   ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ' ------------------------------------------------------------------------------------------------------------------
        ' Le classeur existe - On recherche si la feuille existe
        Workbooks.Open (Chemin2 & sDos & "\" & ficd): Workbooks(ficd).Activate    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
            For Each xshcherchee In Worksheets
                If xshcherchee.Name = xnomsh Then
                    MsgBox "SAUVEGARDE IMPOSSIBLE - Cette feuille " & xnomsh & " existe déjà dans le classeur du joueur : " & xnomfic & ".", vbCritical
                    ActiveWorkbook.Save: ActiveWorkbook.Close
                    Workbooks("Musculation.xlsm").Sheets("Modele").Activate
                    Exit Sub
                End If
            Next
            
        ' Le classeur existe - On ajoute la feuille
        Worksheets.Add After:=Sheets((Sheets.Count)): Worksheets(Sheets.Count).Name = xnomsh
        Workbooks("Musculation.xlsm").Sheets("Modele").Range("A:P").Copy
            With ActiveWorkbook.Sheets(xnomsh)
                .Range("A:P").PasteSpecial Paste:=xlPasteValues
                .Range("A:P").PasteSpecial Paste:=xlPasteFormats
                .Range("A:P").PasteSpecial Paste:=xlPasteFormulas
            End With
        Application.CutCopyMode = False
        MsgBox "Sauvegarde effectuée."
        'ActiveWorkbook.SaveAs Filename:="C:\Users\coach\dropbox\Musculation\" & xnomfic & " Musculation.xlsx"    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ActiveWorkbook.Save
        ActiveWorkbook.Close
        Workbooks("Musculation.xlsm").Sheets("Modele").Activate
        ' ------------------------------------------------------------------------------------------------------------------
    Else
        '___________________________________________________________________________________________________________________
        ' Création du fichier ou classeur et copie de la feuille modele
        Workbooks.Add
        Workbooks("Musculation.xlsm").Sheets("Modele").Range("A:P").Copy
            With ActiveWorkbook.Sheets("Feuil1")
                .Range("A:P").PasteSpecial Paste:=xlPasteValues
                .Range("A:P").PasteSpecial Paste:=xlPasteFormats
                .Range("A:P").PasteSpecial Paste:=xlPasteFormulas
            End With
        Application.CutCopyMode = False
        ActiveSheet.Name = xnomsh
        ActiveWorkbook.SaveAs Filename:=Chemin2 & sDos & "\" & xnomfic & " Musculation.xlsx"    ' MODIFIER LE CHEMIN DU REPERTOIRE - SI NECESSAIRE
        ActiveWorkbook.Close
        MsgBox "Sauvegarde effectuée."
    End If
    
    End If
        '___________________________________________________________________________________________________________________
    Application.ScreenUpdating = True
End Sub

je ne trouve pas le problème, c'est la premièrefois que je suis sur un code aussi complexe notamment grâce à bbb38, mais là j'avoue je bloque un peu.
merci encore pour le temps que vous prenez! je vous avoue avoir acheté un livre sur le langage VBA car je m'y intéresse de plus en plus et cela grâce à des gens comme vous !
Cordialement
Julien
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Question
Microsoft 365 Copier un dossier et son contenu puis y enregistrer un classeur. Renommer chaque élément selon des valeurs de cellules
Réponses
1
Affichages
481
Zon
Z
A
  • Question
Microsoft 365 VBA: importer dans un dossier avec un nom variable
Réponses
4
Affichages
749
A-F
A
S
  • Question
XL 2019 Enregistrer plusieurs feuilles excel en un fichier PDF dans un dossier portant le nom d'une cellule
Réponses
4
Affichages
1 K
Phil69970
Phil69970
O
  • Question
XL 2010 suppression fichiers excel vba
Réponses
9
Affichages
386
Oneida
Oneida
A
  • Question
XL 2010 Date dans fichier pour impression pdf
Réponses
2
Affichages
757
Aldonanou
A
K
  • Résolu(e)
Microsoft 365 Ouvrir un autre classeur excel (VBA) pour utiliser les données de celui dans le classeur actif
Réponses
5
Affichages
840
Dranreb
Dranreb
A
  • Question
XL 2019 Résolu - Bug code VBA modifier xxx fichiers en boucle
Réponses
3
Affichages
500
fanch55
fanch55
R
  • Question
XL 2010 VBA : consolidation
Réponses
2
Affichages
722
Rousseau Benoit
R
O
  • Résolu(e)
XL 2013 Rajouter une bordure noire dans un tableau par VBA
Réponses
5
Affichages
704
Lolote83
L
B
  • Question
XL 2019 bug dans l'enregistrement (VBA)
Réponses
9
Affichages
1 K
bluesky12000
B

Membres actuellement en ligne

Aucun membre en ligne actuellement.
2 membres et 30 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 229
Messages
2 086 426
Membres
103 206
dernier inscrit
diambote