XL 2021 Sauvegarder répertoire/sous répertoire un peu volumineux 2 Go

[Claudinedu13]

Bonjour,

Grâce à une solution donnée dans cette discussion

XL 2010 - Comment copier tous les fichiers d'un répertoire et de ses sous-répertoires vers un dossier unique ?

Bonjour Je travaille sous Excel 2010 sous Windows 2010 Entreprise Je cherche une macro vba qui me permettrait d'extraire (copier), tous les fichiers d'un répertoire et de ses sous-répertoires, vers un répertoire unique (nommé par exemple : extract). Je pense que ceci doit être très facile pour...

excel-downloads.com

par @patricktoulon , je peux faire des sauvegardes de répertoires/sous répertoires

la copie de mes répertoires et fichiers se fait rapidement (le poids est de 2Go) , mais excel reste bloqué sur "ne répond pas"

J'ai testé sur du petit contenu , ça ne bloque pas

Avez-vous une solution svp ?

Sub test()
    Dim racine$
    racine = "C:\Users\" & VBA.Environ("USERNAME") & "\Desktop\Fournitures"
    tableau = recherche_récursive(racine)
    'Cells(1, 1).Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
End Sub
'
'
Private Function recherche_récursive(dparent, Optional L As String) As Variant
    Dim FSO As Object, Lparent As Object, SubFolder As Object, Ficher
    Set FSO = CreateObject("scripting.filesystemobject")    ' on declare l'object
    ' regard sur les fichiers
    Set Lparent = FSO.GetFolder(dparent)    'on attribue a l'object.getfolder le dossier demandé 'Scripting.Folder
    SourceCopie = "C:\Users\" & VBA.Environ("USERNAME") & "\Desktop\Fournitures"
    DestinationCopie = "C:\Users\" & VBA.Environ("USERNAME") & "\Desktop\Save"
    
    'MsgBox GetAttr(Lparent)
    If GetAttr(Lparent) <> 22 Then
        For Each Ficher In Lparent.Files    'on boucle sur les fichiers qui sont dans ce dossier
            L = L & Ficher & vbCrLf
            FSO.CopyFolder SourceCopie, DestinationCopie
        '!!!!!!!!!!!!!c'est ici qu'il faut faire la copie!!!!!!!!!!!!!
        Next

        'boucles sur les sous dossiers
        For Each SubFolder In Lparent.SubFolders    'on boucle sur les dossiers qui sont dans ce dossiers
            L = L & SubFolder.Path & vbCrLf
            recherche_récursive SubFolder.Path, L   ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et L qui est déjà peut être remplie
        Next SubFolder
    End If

    recherche_récursive = Split(L, vbCrLf)    'on coupe la liste par les saut de lignes on a maintenant un array la fonction devient cet array
End Function

 

[scraper]

Bonjour Claudinedu13

Avant le traitement de recherche faire :
Dim savedCalcMode As XlCalculation
savedCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
....
tableau = recherche_récursive(racine)

....
Après traitement:
Application.Calculation = savedCalcMode

 

[Claudinedu13]

Bonjour Claudinedu13

Avant le traitement de recherche faire :
Dim savedCalcMode As XlCalculation
savedCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
....
tableau = recherche_récursive(racine)

....
Après traitement:
Application.Calculation = savedCalcMode

Bonjour, il n'y a pas de changement , c'est bien comme ça que je mets ton code ou je me trompe ?

Sub test()
    Dim racine$
    racine = "C:\Users\" & VBA.Environ("USERNAME") & "\Desktop\Fournitures"
Dim savedCalcMode As XlCalculation
savedCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
    tableau = recherche_récursive(racine)
    'Cells(1, 1).Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
Application.Calculation = savedCalcMode
End Sub

 

[scraper]

Bonjour, il n'y a pas de changement , c'est bien comme ça que je mets ton code ou je me trompe ?

Sub test()
    Dim racine$
    racine = "C:\Users\" & VBA.Environ("USERNAME") & "\Desktop\Fournitures"
Dim savedCalcMode As XlCalculation
savedCalcMode = Application.Calculation
Application.Calculation = xlCalculationManual
    tableau = recherche_récursive(racine)
    'Cells(1, 1).Resize(UBound(tableau) + 1, 1) = Application.Transpose(tableau)
Application.Calculation = savedCalcMode
End Sub

Oui c'est cela. Mettre la déclaration de la variable Fso en global. Et remonter la ligne set Fso = createobject de manière à ne pas créer un objet a chaque appel recursif

 

[jurassic pork]

Hello,
cela m'étonne que patricktoulon n'est pas réagi, parce que ton code est franchement bizarre car en fait tes boucles ne servent à rien car un seul CopyFolder suffit ( il copie les fichiers des répertoires et des sous-répertoires) Normalement ce code suffit :

Sub CopieRépertoire()
  Dim fso As Object
  Dim SrcCopie As String, DstCopie As String
  Set fso = CreateObject("scripting.filesystemobject")
  SrcCopie = "D:\Dev\office\Excel"
  DstCopie = "D:\tmp\Save"
  fso.CopyFolder SrcCopie, DstCopie
  Set fs = Nothing
  MsgBox "Fin"
End Sub

En ce qui concerne le blocage c'est normal car le CopyFolder va monopoliser le CPU réservé pour Excel.
Pour éviter ce souci on peut utiliser la commande windows RoboCopy en mode asynchrone, c'est à dire qu'elle se lance en tâche de fond et on reprend tout de suite la main dans Excel. Pendant l'exécution de la copie une fenêtre console s'ouvre pour indiquer la progression de la copie . Exemple de code :

Sub RobocopyAsync()
    Dim shell As Object
    Dim SrcCopie As String, DstCopie As String
    Dim robocopyCmd As String
    Set shell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    shell.Run "cmd /c " & robocopyCmd, vbNormalFocus
End Sub

On peut aussi attendre la fin et afficher la progression dans la fenêtre d'exécution VBA :

Sub RobocopySync()
    Dim objShell As Object, objExec As Object
    Dim SrcCopie As String, DstCopie As String
    Dim strOutput As String, robocopyCmd As String
    Set objShell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    Set objExec = objShell.Exec("cmd /c chcp 1252 > nul  & cmd /c " & robocopyCmd)
    Do While Not objExec.StdOut.AtEndOfStream
       strLine = objExec.StdOut.ReadLine
       Debug.Print strLine
       DoEvents
    Loop
End Sub

Il n'y a pas énormément de différence de temps de copie entre CopyFolder et RoboCopy malgré l'affichage dans RobotCopy.

Ami calmant, J.P

 

[Claudinedu13]

Hello,
cela m'étonne que patricktoulon n'est pas réagi, parce que ton code est franchement bizarre car en fait tes boucles ne servent à rien car un seul CopyFolder suffit ( il copie les fichiers des répertoires et des sous-répertoires) Normalement ce code suffit :

Sub CopieRépertoire()
  Dim fso As Object
  Dim SrcCopie As String, DstCopie As String
  Set fso = CreateObject("scripting.filesystemobject")
  SrcCopie = "D:\Dev\office\Excel"
  DstCopie = "D:\tmp\Save"
  fso.CopyFolder SrcCopie, DstCopie
  Set fs = Nothing
  MsgBox "Fin"
End Sub

En ce qui concerne le blocage c'est normal car le CopyFolder va monopoliser le CPU réservé pour Excel.
Pour éviter ce souci on peut utiliser la commande windows RoboCopy en mode asynchrone, c'est à dire qu'elle se lance en tâche de fond et on reprend tout de suite la main dans Excel. Pendant l'exécution de la copie une fenêtre console s'ouvre pour indiquer la progression de la copie . Exemple de code :

Sub RobocopyAsync()
    Dim shell As Object
    Dim SrcCopie As String, DstCopie As String
    Dim robocopyCmd As String
    Set shell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    shell.Run "cmd /c " & robocopyCmd, vbNormalFocus
End Sub

On peut aussi attendre la fin et afficher la progression dans la fenêtre d'exécution VBA :

Sub RobocopySync()
    Dim objShell As Object, objExec As Object
    Dim SrcCopie As String, DstCopie As String
    Dim strOutput As String, robocopyCmd As String
    Set objShell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    Set objExec = objShell.Exec("cmd /c chcp 1252 > nul  & cmd /c " & robocopyCmd)
    Do While Not objExec.StdOut.AtEndOfStream
       strLine = objExec.StdOut.ReadLine
       Debug.Print strLine
       DoEvents
    Loop
End Sub

Il n'y a pas énormément de différence de temps de copie entre CopyFolder et RoboCopy malgré l'affichage dans RobotCopy.

Ami calmant, J.P

Bonjour @jurassic pork

Super j'ai adopté ton 2ème code , j'aime bien la fenêtre qui s'ouvre avec la progression.

J'ai une petite demande supplémentaire, je voudrais que DstCopie soit vidé de tous ces dossiers/fichiers avant d'y faire une nouvelle sauvegarde avec ton code ?

Merci

 

[jurassic pork]

Tu peux faire comme cela par exemple :

Sub RobocopyAsync()
    Dim shell As Object
    Dim SrcCopie As String, DstCopie As String
    Dim robocopyCmd As String
    Dim fso As Object
    Set fso = CreateObject("scripting.filesystemobject")
    Set shell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    On Error Resume Next
    'Effacer fichiers et sous-répertoires
    fso.DeleteFile DstCopie & "\*.*", True
    fso.DeleteFolder DstCopie & "\*.*", True
    On Error GoTo 0
    'Copier fichiers et sous-répertoires
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    shell.Run "cmd /c " & robocopyCmd, vbNormalFocus
End Sub

Sachant que robocopy peut faire de la copie intelligente avec par exemple l'option /purge :

Lorsque vous utilisez l’option /purge, Robocopy supprime les fichiers et répertoires de destination qui ne sont plus présents dans la source. Cela signifie que si un fichier ou un répertoire a été supprimé de la source, il sera également supprimé de la destination.

 

[Claudinedu13]

Tu peux faire comme cela par exemple :

Sub RobocopyAsync()
    Dim shell As Object
    Dim SrcCopie As String, DstCopie As String
    Dim robocopyCmd As String
    Dim fso As Object
    Set fso = CreateObject("scripting.filesystemobject")
    Set shell = CreateObject("WScript.Shell")
    SrcCopie = "D:\Dev\office\Excel"
    DstCopie = "D:\tmp\Save"
    On Error Resume Next
    'Effacer fichiers et sous-répertoires
    fso.DeleteFile DstCopie & "\*.*", True
    fso.DeleteFolder DstCopie & "\*.*", True
    On Error GoTo 0
    'Copier fichiers et sous-répertoires
    robocopyCmd = "robocopy """ & SrcCopie & """ """ & _
                   DstCopie & """ /S"
    shell.Run "cmd /c " & robocopyCmd, vbNormalFocus
End Sub

Sachant que robocopy peut faire de la copie intelligente avec par exemple l'option /purge :

Merci @jurassic pork