Blocage de l'explorer Windows pendant exécution macro

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

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