XL 2013 ecraser fichier excel dans plusieurs sous-dossiers répartis dans différents répertoires

[GADENSEB]

Bonjour le Forum
Je souhaiterais enregistrer, a l'enregistrement ou fermeture, un fichier excel dans plusieurs sous-dossiers répartis dans différents répertoires.
je l'ai nommé : ALPHA 1.xlsx

Je vous explique mon schéma
- Ouverture du fichier : je scanne un répertoire et ses sous-répertoires pour trouver tous les fichiers du même nom
- J'enregistre ces cibles dans une ou plusieurs variables
- A l'enregistrement/fermeture du fichier : un pop-up me demande de confirmer l'écrasement des cibles contenues dans les variables précédentes.
- Écrasement ou non des cibles.
- Enregistrement du fichier dans le dossier ou je l'ai ouvert
- Proposer un nouvel endroit ou plusieurs ou l'enregistrer.....

Est-ce jouable ?

En vous remerciant
et bonne nuit
Seb

 

[job75]

Bonjour GADENSEB, le forum,

Oui c'est jouable, il faudra utiliser une méthode récursive pour analyser tous les sous-dossiers à partir du fichier de la macro.

A+

 

[job75]

Mettez tout ce code dans le module que vous voulez :

Dim fso As Object, liste, n& 'mémorise les variables

Sub EcraserFichiers()
Dim chemin$, nom$
With ThisWorkbook
    chemin = .Path
    nom = .Name
    Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim liste(0) 'RAZ
    n = 0 'RAZ
    ListeRecursive fso.getfolder(chemin), nom
    Application.DisplayAlerts = False
    If n Then
        For n = 0 To UBound(liste)
            .SaveAs liste(n)
        Next
    End If
    MsgBox IIf(n, n, "Aucun") & " fichier" & IIf(n > 1, "s", "") & " écrasé" & IIf(n > 1, "s", "") & " dans les sous-dossiers"
    .SaveAs chemin & "\" & nom
End With
Set fso = Nothing
End Sub

Sub ListeRecursive(f As Object, nom$)
Dim sf As Object
For Each sf In f.subfolders
    If Dir(sf & "\" & nom) <> "" Then
        ReDim Preserve liste(n)
        liste(n) = sf & "\" & nom
        n = n + 1
    End If
    ListeRecursive fso.getfolder(sf), nom
Next sf
End Sub

Edit : ajouté la MsgBox.

 

[GADENSEB]

Hello
Merci de ce fichier
Super job.
Je teste cela ce soir !!
A plus
Merci

 

[GADENSEB]

Hello Job75
je viens de tester ton fichier
cela semble marcher normalement merci
J'aurais du préciser dans mon premier post que le recherche récursive devait se positionner, mea culpa, dans un dossier précis
chemin = "E:\Logiciels\00 - PROJETS"
ce chemin inclut le dossier dans lequel est le fichier dont on s'occupe, il faut donc l'exclure dans la recherche récursive...
J'ai cette erreur après ma modification de "Chemin"
Comment faire cette exclusion ?

Bonne journée à toi

Dim fso As Object, liste, n& 'mémorise les variables

Sub EcraserFichiers()
Dim chemin$, nom$
With ThisWorkbook
    chemin = "E:\Logiciels\00 - PROJETS"
    'chemin = .Path
    nom = .Name
    Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim liste(0) 'RAZ
    n = 0 'RAZ
    ListeRecursive fso.getfolder(chemin), nom
    Application.DisplayAlerts = False
    If n Then
        For n = 0 To UBound(liste)
            .SaveAs liste(n)
        Next
    End If
    MsgBox IIf(n, n, "Aucun") & " fichier" & IIf(n > 1, "s", "") & " écrasé" & IIf(n > 1, "s", "") & " dans les sous-dossiers"
    .SaveAs chemin & "\" & nom
End With
Set fso = Nothing
End Sub

Sub ListeRecursive(f As Object, nom$)
Dim sf As Object
For Each sf In f.subfolders
    If Dir(sf & "\" & nom) <> "" Then
        ReDim Preserve liste(n)
        liste(n) = sf & "\" & nom
        n = n + 1
    End If
    ListeRecursive fso.getfolder(sf), nom
Next sf
End Sub

 

[job75]

chemin = "E:\Logiciels\00 - PROJETS"
ce chemin inclut le dossier dans lequel est le fichier dont on s'occupe, il faut donc l'exclure dans la recherche récursive...

Il est tout à fait inutile de faire une quelconque exclusion.

Simplement le fichier de la macro sera enregistré 2 fois : une fois dans son sous-dossier et une fois en fin de macro dans le dossier chemin.

J'ai testé moi aussi comme vous l'avez fait avec un dossier "antérieur", sans aucun problème.

Je ne sais pas d'où vient le bug avec la fonction Dir : quand le fichier n'est pas trouvé elle renvoie normalement "".

Il faudrait que vous nous disiez quel est la valeur du sous-dossier sf au moment du bug : placez le curseur dessus.

 

[job75]

Bonjour GADENSEB,

J'ai lu quelque part que Dir peut entraîner un bug quand on l'utilise dans des itérations.

Avec ce code on l'évite mais c'est plus long :

Dim fso As Object, liste, n& 'mémorise les variables

Sub EcraserFichiers()
Dim debut$, chemin$, nom$
With ThisWorkbook
    debut = "E:\Logiciels\00 - PROJETS"
    chemin = .Path
    nom = LCase(.Name) 'minuscules
    Set fso = CreateObject("Scripting.FileSystemObject")
    ReDim liste(0) 'RAZ
    n = 0 'RAZ
    ListeRecursive fso.getfolder(debut), nom
    Application.DisplayAlerts = False
    If n Then
        For n = 0 To UBound(liste)
            .SaveAs liste(n)
        Next
    End If
    MsgBox IIf(n, n, "Aucun") & " fichier" & IIf(n > 1, "s", "") & " écrasé" & IIf(n > 1, "s", "") & " dans les sous-dossiers"
    .SaveAs chemin & "\" & nom
End With
Set fso = Nothing
End Sub

Sub ListeRecursive(f As Object, nom$)
Dim sf As Object, fich As Object
For Each sf In f.subfolders
    For Each fich In fso.getfolder(sf).Files
        If LCase(fich.Name) = nom Then
            ReDim Preserve liste(n)
            liste(n) = sf & "\" & nom
            n = n + 1
        End If
    Next fich
    ListeRecursive fso.getfolder(sf), nom
Next sf
End Sub

Bonne journée.

 

[GADENSEB]

Hello.
Merci a toi.
Je teste cela ce soir.
Merci bien
Bonne journée

 

[GADENSEB]

Bonjour
c'est parfait
cela marche au poil
je te remercie

bonne soirée