XL 2016 Bouton pour créer un dossier et enregistrer un fichier dedans les deux avec le mêmes nom

!xmusaton

XLDnaute Nouveau
Bonjour à tous,

J'ai un bouton avec code qui enregistre une copie d'un fichier xlsm mais sans macro dans un répertoire défini, tout en ayant un nom selon le contenu de trois cellules G3-H3-F9

Simplement, je voudrais qu'il me crée un dossier avec exactement le meme nom du fichier et mettre le fichier dedans

Que faut-il ajouter dans ce code?

</> Private Sub Bouton2_Cliquer()

Dim endroit As String, Nom_De_Fichier As String

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "A:\Dossier compta"
If .Show = -1 Then
endroit = .SelectedItems(1) & "\"
On Error GoTo 100 'Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.ActiveSheet.Copy
Nom_De_Fichier = Range("$G$3") & Range("$H$3") & "_" & Range("$F$9") & ".xlsx"
With ActiveWorkbook
.ActiveSheet.DrawingObjects.Delete
.SaveAs Filename:=endroit & Nom_De_Fichier
.Close
MsgBox "Votre commande est sauvegardée"
End With
Else
End If

End With
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Exit Sub
100

End Sub </>


Merci!
 
Dernière édition:
C

Compte Supprimé 979

Guest
Re,

Merci, mais presque 😁 pour le code
1637078115976.png


Sinon voici le code (mise entre balises)à essayer ;)
VB:
Private Sub Bouton2_Cliquer()
  Dim Endroit As String, Nom_De_Fichier As String
  ' Se positionner par défaut
  ChDir "A:\Dossier compta"
  ' Ouvrir la boite de dialogue
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Sélectionnez le répertoire"
    If .Show = -1 Then
      Endroit = .SelectedItems(1) & "\"
    End If
  End With
  ' Si l'utilisateur à annulé
  If Endroit = "" Then GoTo FinSub
  ' Chemin sélectionén on continue
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Nom_De_Fichier = Range("$G$3") & Range("$H$3") & "_" & Range("$F$9")
  ' Ajouter le nom du fichier dans le chemin d'accès
  Endroit = Endroit & Nom_De_Fichier
  ' Vérifier si existe
  If Dir(Endroit, vbDirectory) = "" Then
    ' Sinon le créer
    MkDir Endroit
  End If
  ' Copier la feuille
  ThisWorkbook.ActiveSheet.Copy
  ' Sauvegarder le classeur
  With ActiveWorkbook
    .ActiveSheet.DrawingObjects.Delete
    .SaveAs Filename:=Endroit & Nom_De_Fichier & ".xlsx"
    .Close
    MsgBox "Votre commande est sauvegardée"
  End With
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
FinSub:
End Sub

A+
 
Dernière modification par un modérateur:

Discussions similaires

Réponses
1
Affichages
269
Compte Supprimé 979
C