Enregistrer csv

Bonjour à tous,

J'ai réalisé un petit programme qui sauvegarde des feuilles de mon classeur excel en format csv dans un répertoire de mon choix. Le programme le fait très bien, sauf que je rencontre trois petits problèmes:

1- le nom que je donne pour les fichiers csv, il le donne automatiquement à aux feuilles excel de mon classeur.
2- la dernière feuille lors de l'enregistrement en csv prend le nom pricing_ENT hors je veux que seul le dossier se sauvegarde ainsi.
3- Et enfin lors du l'exécution du programme, il met trop de temps à enregistrer les 4 feuilles en csv, ce qui me gène un peu.

Je ne sais pas quoi faire face à ces 3 problèmes, si quelqu'un peut bien m'aider.
Merci d'avance, voici le programme:

Sub Enregistrer_Click()

Dim i As Byte
Dim chemin As String
Dim objShell As Object, objFolder As Object, oFolderItem As Object


For i = 6 To 9

Sheets(i).Select

Chx = MsgBox("où voulez-vous sauvegarder?", vbYesNo + vbQuestion, "mDF XLpages.com")
If Chx = vbYes Then
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire pour l'enregistrement du fichier", &H1&)
Set oFolderItem = objFolder.Items.Item
chemin = oFolderItem.Path & "\"

nom = InputBox("Indiquer le nom du fichier :")
ActiveWorkbook.SaveAs Filename:=chemin & nom & ".csv", FileFormat:=xlCSV, local:=True
MsgBox chemin & nom & ".csv"

Else
CreateObject("Wscript.shell").Popup "Le fichier n'a pas été sauvegardé... Merci", vbExclamation

End If

Next i

ThisWorkbook.SaveAs ("Pricing_ENT")


End Sub