Problématique de sauvegarde avec une macro

Bonjour,

Je rencontre une problématique avec une macro.

Je souhaite qu'un fichier soit enregistré sous un nom précis, s'il existe déjà, il faut créer une séquence derrière (ex: 1 ; 2 ; 3 ....) sans devoir écraser le premier.

Voici mon code :

Code :

Dim CheminDossier As String
    CheminDossier = "C:\Users\Benjamin\Documents\3DM\Devis" & "\" & Sheets("feuil3").[A2]
On Error Resume Next
MkDir CheminDossier

Dim x As String, i As Byte
x = CheminDossier & "\" & Sheets("feuil3").[A4] & ".xlsm"
If x <> "" Then
    Do
        x = CheminDossier & "\" & Sheets("feuil3").[A4] & "-" & i + 1 & ".xlsm"
        i = i + 1
    Loop While x <> ""
    ThisWorkbook.SaveAs Sheets("feuil3").[A4] & "-" & i & ".xlsm"
Else
    ThisWorkbook.SaveAs Sheets("feuil3").[A4] & ".xlsm"
End If

Quelqu'un aurait-il une solution car je ne peux même pas savoir si la macro marche ou non, on dirait qu'elle fait planter excel ?

Bonjour Benjamin

1) Mets en annotation ta ligne

On Error Resume Next

2) Pour moi tu oublies l'instruction DIR()

x = DIR(CheminDossier & "\" & Sheets("feuil3").[A4] & ".xlsm")

et

x = DIR(CheminDossier & "\" & Sheets("feuil3").[A4] & "-" & i + 1 & ".xlsm")

A+

J'ai bien pris en charge les options :

Sub Sauvegarde()
'
' Enregistrer_excel
'
Dim CheminDossier As String
    CheminDossier = "C:\Users\Benjamin\Documents\3DM\Devis" & "\" & Sheets("feuil3").[A2]
'On Error Resume Next
MkDir CheminDossier

Dim x As String, i As Byte
x = Dir(CheminDossier & "\" & Sheets("feuil3").[A4] & ".xlsm")
If x <> "" Then
    Do
        x = Dir(CheminDossier & "\" & Sheets("feuil3").[A4] & "-" & i + 1 & ".xlsm")
        i = i + 1
    Loop While x <> ""
    ThisWorkbook.SaveAs Sheets("feuil3").[A4] & "-" & i & ".xlsm"
Else
    ThisWorkbook.SaveAs Sheets("feuil3").[A4] & ".xlsm"
End If

End Sub

Le problème, il y a bien création de dossier mais ca s'arrête là, car il y a un debogage au Mkdir

Erreur 75 Accès dossier/fichier si j'appuis à nouveau sur le bouton macro.

Ci joint le fichier pour plus de compréhension la macro est sur la feuille "Devis"

Merci

Re,

Il faut effectivement faire un test pour la création du dossier ou non

Car s'il existe déjà, Mkdir retourne une erreur

Sub Sauvegarde()
  Dim CheminDossier As String
  Dim x As String, i As Byte
  CheminDossier = "D:\Users\Benjamin\Documents\3DM\Devis" & "\" & Sheets("feuil3").[A2]
  ' Vérifier si le répertoire existe ou non
  If Dir(CheminDossier, vbDirectory) = "" Then
    ' s'il n'existe pas, le créer
    MkDir CheminDossier
  End If
  ' Vérifier si le fichier existe
  x = Dir(CheminDossier & "\" & Sheets("feuil3").[A4] & ".xlsm")
  If x <> "" Then
    ' S'il existe, incrémenter le nom
    Do
      ' Incrémenter
      i = i + 1
      ' Vérifier s'il existe un nom de fichier identique, renvoie "" si faux
      x = Dir(CheminDossier & "\" & Sheets("feuil3").[A4] & "-" & i & ".xlsm")
    ' Recommencer tant qu'il existe un nom de fichier identique
    Loop While x <> ""
    ' Sauvegarder sous le nom trovué
    ThisWorkbook.SaveAs CheminDossier & "\" & Sheets("feuil3").[A4] & "-" & i & ".xlsm"
  Else
    ThisWorkbook.SaveAs CheminDossier & "\" & Sheets("feuil3").[A4] & ".xlsm"
  End If
End Sub

A+

Merci,

le problème est résolu mais pour information, si je veux faire la même macro sous le format excel, comment choisir l'extention car en remplacant .xlsm par .pdf cela ne fonctionne pas non ?