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

[Résolu/Fermé]
Signaler
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
-
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
-
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!

2 réponses

Messages postés
7568
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 octobre 2021
663
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1
Merci pour la réponse!

Mais je ne suis pas capable de l'adapter à mon cas parce que mon répertoire n'est pas toujours le même. J'obtien une erreur d'exécution 75.

Dans mon cas, le début est toujours pareil jusqu'au répertoire Piézomètres et ensuite il varie selon la sélection faite et je veux ajouter un sous-répertoire (Transfert) dans ce répertoire (qui varie).

J'ai essayé ceci:
If Dir("M:\Entrepot\BDFS\1_Piézomètres\" & vbDirectory & "\Transfert") = "" Then
                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
            Else
            Resume Next
            End If
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1
Deuxième essai, j'ai modifié un peu pour ceci:
If Dir(Chemin, vbDirectory) = "" Then
                MkDir "Transfert"
            End If
            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
Mais cette fois-ci, si je sélectionne deux fichiers, il n'en sauvegarde que un sur deux.
Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1
Je crois avoir trouvé une solution la voilà:
Chemin = CurDir & "\Transfert\"
            If Dir(Chemin, vbDirectory) = "" Then
                MkDir "Transfert"
                Fichier = Nomclasseur & "_traité" & ".xlsx"
                On Error Resume Next
                    With ActiveWorkbook
                        Application.DisplayAlerts = False
                        .SaveAs Filename:=Chemin & Fichier
                        .Close
                        Application.DisplayAlerts = True
                    End With
                Else
                    Chemin = CurDir & "\Transfert\"
                    Fichier = Nomclasseur & "_traité" & ".xlsx"
                    On Error Resume Next
                        With ActiveWorkbook
                            Application.DisplayAlerts = False
                            .SaveAs Filename:=Chemin & Fichier
                            .Close
                            Application.DisplayAlerts = True
                End With
            End If


Ça fonctionne, mais je ne sais pas s'il y a une façon plus optimal d'écrire le code? J'ai une répétition des lignes de codes pour la sauvegarde du fichier.

Vos commentaires sont les bienvenue!
Messages postés
7568
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
14 octobre 2021
663
Bien sur qu'il y a une répétition!
C'est l'enregistrement.
essaie cela:

Chemin = CurDir & "\Transfert\"
            If Dir(Chemin, vbDirectory) = "" Then
                MkDir "Transfert"
                Fichier = Nomclasseur & "_traité" & ".xlsx"
              Else
                    Chemin = CurDir & "\Transfert\"
                    Fichier = Nomclasseur & "_traité" & ".xlsx"
                    End If
                  With ActiveWorkbook
                            Application.DisplayAlerts = False
                            .SaveAs Filename:=Chemin & Fichier
                            .Close
                            Application.DisplayAlerts = True
                End With



Messages postés
270
Date d'inscription
jeudi 19 février 2015
Statut
Membre
Dernière intervention
12 avril 2021
1
Merci beaucoup pour la réponse!

Je n'y avais vraiment pas pensé, c'était pourtant si simple!

Encore merci!