Autres Problème de compatibilité Excel 97-2003

'---- Exécuter la procédure Appel ----
Sub Appel()
Dim FL1 As Workbook, Chemin As String
Const ssfTous = &H1
Dim objShell As Object, objFolder As Object, oFolderItem As Object
  
ActiveWorkbook.Sheets("Recap").Activate
Range("A1:AA100000").Select
Selection.ClearContents
Range("A1").Select
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", ssfTous)
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path
    Set objShell = Nothing
    Set objFolder = Nothing
    Set oFolderItem = Nothing
    Application.ScreenUpdating = False
        Set FL1 = ThisWorkbook
        Ouvrir Chemin, FL1
    Application.ScreenUpdating = True
    If msg = "" Then
        MsgBox "Copie des fichiers terminée, sans souci."
    Else
        MsgBox "Pour des raisons de protection ou autres, n'ont pu être copiés :" & vbCrLf & msg
    End If
    ActiveWorkbook.Worksheets("feuil1").Activate
End Sub
'---- Ouverture des fichiers ----
Sub Ouvrir(Chemin As String, FL1 As Workbook)
Dim NomFich As String
    NomFich = Dir(Chemin & "\")
    'If NomFich = "" Or Right(NomFich, 4) <> ".xls" Then
         MsgBox "Aucun fichier trouvé dans " & Chemin & "."
         Exit Sub
    End If
    Do While NomFich <> ""
        Application.EnableEvents = False
            Workbooks.Open Chemin & "\" & NomFich
            DoEvents
        Application.EnableEvents = True
        NomFich = ActiveWorkbook.Name
        Copie NomFich, FL1
        NomFich = Dir
    Loop
End Sub
'---- Copie des feuilles ----
Sub Copie(NomFich As String, FL1 As Workbook)
    Application.EnableEvents = False
        For Each LaFeuille In Workbooks(NomFich).Worksheets
            'MsgBox LaFeuille.Name
            On Error Resume Next
            LaFeuille.Copy After:=FL1.Sheets(FL1.Sheets.Count)
            DoEvents
            If ActiveSheet.Protect = True Then ActiveSheet.Unprotect
            ActiveSheet.UsedRange.Copy
            ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues
            If Err <> 0 Then
                msg = msg & "Classeur " & NomFich & " feuille " & LaFeuile.Name & vbCrLf
                Err.Clear
                On Error GoTo 0
            End If
            DoEvents
            If Cpt Mod 200 = 0 Then
                ThisWorkbook.Save
                DoEvents
            End If
        Next
    Application.EnableEvents = True
    'Fermeture du classeur
    Application.DisplayAlerts = False
        Workbooks(NomFich).Close False
    Application.DisplayAlerts = True
    DoEvents

Call RegroupeFeuilles   'dans Récap"
End Sub
'---- Regrouper les onglets ----
Sub RegroupeFeuilles() 'dans Récap"
Dim Lg&, Sh As Worksheet, f As Worksheet
        Set f = Sheets("Récap")
    f.Range("a1:k" & f.[a65000].End(xlUp).Row).ClearContents    'efface Récap
  
    For Each Sh In Worksheets
        If Sh.Name <> f.Name And Sh.Name <> "Feuil1" Then         'feuilles à ne pas traiter
            Lg = Sh.Range("a" & Rows.Count).End(xlUp).Row
            Sh.Range("a1:k" & Lg).Copy Destination:= _
            f.Range("a" & Rows.Count).End(xlUp)(2)
        End If
    Next

End Sub