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

[!xmusaton]

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!

 

[Compte Supprimé 979]

Re,

Merci, mais presque pour le code

Sinon voici le code (mise entre balises)à essayer

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+