Ajout d'un sous-répertoire avant la sauvegarde de fichiers

Bonjour à tous!

J'ai une petite question, j'ai ajouté à ma macro un code pour ajouter un sous-répertoire automatiquement dans mon répertoire avant de sauvegarder mes fichiers dedans.

Mon problème, c'est qu'il crée le sous-répertoire lorsqu'il n'existe pas, mais lorsqu'il existait déjà, j'obtenais un message d'erreur. J'ai réussi à contourner se problème en ajoutant

On Error Resume Next

avant ma ligne

MkDir "Transfert"

.

Je me demande si c'est la meilleur façon de faire ou il y d'autre option?

Voici toute ma macro:

Option Explicit

Private Sub CommandButton1_Click()

   
    Dim QuelFichier()
    Dim Chemin As String, Fichier As String, Nomclasseur As String
    Dim DerLig As Long
    Dim cible As String
    Dim CptPlein As Long, CptCasse As Long, CptBrise As Long, CptInterr As Long, CptX As Long
    Dim i As Integer, x As Integer, N As Integer
    Dim TInfos
    
    cible = "plein d'eau"
    ChDrive "m"
    ChDir "M:\Entrepot\BDFS\1_Piézomètres\"
'On Error GoTo fin
    QuelFichier = Application.GetOpenFilename("Fichier excel(*.xls; *.xlsx),*.xls;*.xlsx", , , , True)
    If IsArray(QuelFichier) Then
        For i = LBound(QuelFichier, 1) To UBound(QuelFichier, 1)
            Workbooks.Open QuelFichier(i)
            '-------------------------------------------
            'Nom de fichier SANS extention en partant du chemin complet
            Nomclasseur = Left(Mid(QuelFichier(i), InStrRev(QuelFichier(i), "\") + 1), Len(Mid(QuelFichier(i), InStrRev(QuelFichier(i), "\") + 1)) - 4)
            '-------------------------------------------
            Application.ScreenUpdating = False
            
            For x = 2 To Sheets.Count - 1
                With Sheets(x)
                    .Unprotect
                    Sheets(x).Columns("E:O").EntireColumn.Hidden = False
                    DerLig = .Range("D" & Rows.Count).End(xlUp).Row
                    For N = 2 To DerLig
                        Select Case .Range("E" & N).Value
                            Case "plein"
                                .Range("E" & N).Value = 0
                                CptPlein = CptPlein + 1
                            Case "cassé"
                                .Range("E" & N).Value = ""
                                CptCasse = CptCasse + 1
                            Case "brisé"
                                .Range("E" & N).Value = ""
                                CptBrise = CptBrise + 1
                            Case "?"
                                .Range("E" & N).Value = ""
                                CptInterr = CptInterr + 1
                            Case "X", "x"
                                CptX = CptX + 1
                                If .Range("E" & N).Offset(0, 10) = cible Then
                                    .Range("E" & N).Value = 0
                                Else
                                    .Range("E" & N).Value = ""
                                End If
                            Case Else
                        End Select
                        If .Range("D" & N) <> "" Then
                            If .Range("A" & N) <> "" Then
                                TInfos = .Range("A" & N & ":C" & N)
                            Else
                                .Range("A" & N & ":C" & N) = TInfos
                            End If
                        End If
                    Next N
                    .Protect
                End With
            Next x
            On Error Resume Next
            MkDir "Transfert"
            Chemin = CurDir & "\Transfert\"
            Fichier = Nomclasseur & "_traité" & ".xlsx"
            On Error Resume Next
            With ActiveWorkbook
                 Application.DisplayAlerts = False
                .SaveAs Filename:=Chemin & Fichier
                '!!!!!!!!!!!!!! A TESTER
                .Close
                Application.DisplayAlerts = True
            End With
            '-------------------------------------------
        Next i
    Else
        MsgBox "Annuler"
    End If
    MsgBox "Vous avez corrigé :" & vbCrLf & _
                CptX & " : X" & vbCrLf & _
                CptBrise & " : brisé" & vbCrLf & _
                CptCasse & " : cassé" & vbCrLf & _
                CptInterr & " : ?" & vbCrLf & _
                CptPlein & " : plein."
    UserForm1.Hide
    ThisWorkbook.Saved = True
    Application.ScreenUpdating = True
    UserForm2.Show
    
fin:
Application.Quit
End Sub

Merci beaucoup!