Blocage de l'explorer Windows pendant exécution macro

[Emmanuel31]

Bonjour à tous ! 😀

Je sollicite votre aide pour un problème assez peu commun, du moins que je n'avais par avant jamais rencontré.😛

J'ai une macro qui, quand je l'exécute, "fige" mon pc. 😱
La macro ne comporte pas d'erreur dans le sens ou elle fait bien ce que je lui demande de faire, elle me sorts bien un bon résultat à la fin etc ... 😎

C'est juste que pendant l'exécution de celle-ci et jusqu'à sa fin, si j'essaye de survoler la barre Windows avec mes fenêtres etc ... c'est sablier !! Et impossible de changer d'application le temps que la macro se finisse 😡

J'ai essayé de faire un "Application.ScreenUpdating = False" et un "Application.WindowState = xlMinimized" mais rien n'y fait ... 🙁

Une idée pour passer tout ça en tache de fond et ne pas m’empêcher de faire autre chose le temps que ça bosse 😕

Merci à tous !

 

[Victor21]

Re : Blocage de l'explorer Windows pendant exécution macro

Bonjour.

Après examen attentif de votre fichier, et de la macro en question, je n'ai rien vu d'anormal, sauf, peut-être, leur absence en pj.

 

[Emmanuel31]

Re : Blocage de l'explorer Windows pendant exécution macro

Je ne pensais pas que la macro était nécessaire vu qu'elle fonctionne bien, mais au cas où, la voici :

Option Explicit
Option Compare Text

Dim FS As Object
Dim Existe As Boolean
Const Destination = "C:\Tests_Excels\ID\"
'Const Destination = [Paramètres!A6]

Sub MAJ_Liens_BLs()  'Appelle la procédure de recherche des fichiers
    Application.ScreenUpdating = False
    Application.WindowState = xlMinimized
    UserForm1.Label1.Caption = "Mise à jour en cours ... "
    UserForm1.Show 0
    Recherche_BL
    Unload UserForm1
    Application.WindowState = xlNormal
    MsgBox "Mise à jour des liens BLs terminée"
End Sub
Sub Recherche_BL()
    Dim Chemin As String, expression As String
    Dim C As Range
    'Répertoire de départ
    Chemin = "C:\Tests_Excels\Arbo_test"
    'Chemin = [Paramètres!A2]
    Set FS = CreateObject("Scripting.FileSystemObject")
    With Worksheets("Suivi_Détail") 'Nom Feuille à définir
        For Each C In .Range("A8:A" & .Range("A65536").End(xlUp).Row)
            If C <> "" And C.Offset(, 3) = "" Then
            Existe = False
            expression = C.Value
            Call GetFolders(Chemin, expression, C, True)
            End If
        Next
    End With
    'Ce qui précède testait le contenu des sous-répertoires
    'cette ligne teste le contenu source lui-même.
    Call Trouver_Copier_Fichier(Chemin, expression, C)
    Set FS = Nothing
End Sub
Function GetFolders(Chemin As String, _
expression As String, Rg As Range, _
Optional Récursif As Boolean)
Dim répertoire As String
Dim MyFolder As Object, MySubFolder As Object

Set MyFolder = FS.GetFolder(Chemin)

'si récursif est égale à true, rappel de la fonction
If Récursif Then
'Boucle pour chaque sous-répertoire
For Each MySubFolder In MyFolder.SubFolders
répertoire = Chemin & "\" & MySubFolder.Name
'Recherche fichier + copie si trouve
Call Trouver_Copier_Fichier(répertoire, expression, Rg)
'Vérifier le sous-répertoire
GetFolders MySubFolder.Path, expression, Rg, True
Next
End If
End Function
Sub Trouver_Copier_Fichier(répertoire As String, _
expression As String, Rg As Range)
    Dim Fichier As String
    
    'Recherche fichier contenant "Expression définie" et ayant une extension de fichier ".pdf"
    Fichier = Dir(répertoire & "\" & "*" & expression & "*" & ".pdf")
    
    Do While Fichier <> ""
        'Existe = true si le répertoire-destination a été créée
        If Existe = False Then
            'création du répertoire
            FS.CreateFolder Destination & expression
            'Créer le lien hypertexte
            Rg.Offset(, 3).Hyperlinks.Add Rg.Offset(, 3), Destination & expression, , , "BL"
            Existe = True
        End If
        'Copie du fichier vers le nouveau répertoire
        FS.CopyFile répertoire & "\" & Fichier, Destination & expression & "\" & Fichier
        
    Fichier = Dir()
    Loop
End Sub

Elle mets beaucoup de temps à rendre la main car elle cherche de façon récursive dans une grande arborescence et cherche fichier par fichier dedans une correspondance ...

Elle fonctionne bien mais c'est juste que ça "fige" windows le temps de finir la macro ...
Après c'est bon et le résultat est bon.

 

[Emmanuel31]

Re : Blocage de l'explorer Windows pendant exécution macro

Un petit up car plus ça va, plus j'ai de fichiers.

Donc ça prends de plus en plus de temps à "scanner" récursivement, et ça bloque mon windows (enfin, l'explorer) pendant ce temps là ... :-(

 

[Pierrot93]

Re : Blocage de l'explorer Windows pendant exécution macro

Bonjour à tous

mets peut être une instruction "DoEvents" à l'interieur de la boucle "Do Loop"

bonne journée
@+

 

[Emmanuel31]

Re : Blocage de l'explorer Windows pendant exécution macro

Bonjour Pierrot93 et merci pour ton aide.

Me reste plus qu'à trouver comment intégrer ce "Do events" dans ma boucle ... car je ne connais pas cette fonction :-(

 

[Pierrot93]

Re : Blocage de l'explorer Windows pendant exécution macro

Re,

tout simplement comme ceci :

Do While Fichier <> ""
       DoEvents
 'Existe = true si le répertoire-destination a été créée
       If Existe = False Then
            'création du répertoire
           FS.CreateFolder Destination & expression
            'Créer le lien hypertexte
           Rg.Offset(, 3).Hyperlinks.Add Rg.Offset(, 3), Destination & expression, , , "BL"
            Existe = True
        End If
        'Copie du fichier vers le nouveau répertoire
       FS.CopyFile répertoire & "\" & Fichier, Destination & expression & "\" & Fichier
        
    Fichier = Dir()
    Loop

 

[Emmanuel31]

Re : Blocage de l'explorer Windows pendant exécution macro

Merci !!!
Je pensais que c'était une fonction avec arguments et tout le toutim ...
Je vais donc tester ;-)