Macro pour lire et non ouvrir chaque fichiers

[B]Public Sub test_import_noms_dossiers()
Dim mem1 As Long, mem2 As Long, mem3 As Long
    'mémoriser/désactiver les options d'excel
    mem1 = Application.Calculation: Application.Calculation = xlCalculationManual
    mem2 = Application.EnableEvents: Application.EnableEvents = False
    mem3 = Application.ScreenUpdating: Application.ScreenUpdating = False
    
    'exécuter la macro
    On Error Resume Next
     test_import_noms_dossiers_int
    On Error GoTo 0
    
    'rétablir les options d'excel
    Application.Calculation = mem1
    Application.EnableEvents = mem2
    Application.ScreenUpdating = mem3

End Sub[/B]


Private Sub test_import_noms_dossiers_int()
Dim i, j, k As Integer
Dim A As String

A = ActiveWorkbook.Name

With Application.FileSearch
' adresse du répertoire
.LookIn = "G:\DT"
' type ou nom du fichier
.Filename = "*.xls"
' recherche dans les sous-dossiers
.SearchSubFolders = True
' executer la recherche
.Execute
' insertion dans le classeur excel
j = Range("r_deb_tab").Row
For i = 1 To .FoundFiles.Count
    Cells(j, 1) = .FoundFiles(i)
        With ActiveSheet
            .Hyperlinks.Add Anchor:=.Cells(j, 1), _
            Address:=.Cells(j, 1), _
            TextToDisplay:=.Cells(j, 1).Value
            .Hyperlinks(i).ScreenTip = " VERS:" & .Cells(i + 5, 1).Value
        End With
    Workbooks.Open Cells(j, 1).Value, , True
    For k = 1 To Sheets.Count
        Workbooks(A).Sheets(1).Cells(j, 2).Value = Sheets(k).Name
        j = j + 1
    Next k
    ActiveWorkbook.Close
Next i
End With
End Sub

im mem1 As Long, mem2 As Long, mem3 As Long, mem4 As Long
    'mémoriser/désactiver les options d'excel
    mem1 = Application.Calculation: Application.Calculation = xlCalculationManual
    mem2 = Application.EnableEvents: Application.EnableEvents = False
    mem3 = Application.ScreenUpdating: Application.ScreenUpdating = False
    mem4 = Application.DisplayAlerts: Application.DisplayAlerts = xlCalculationManual
    
    'exécuter la macro
    On Error Resume Next
     test_import_noms_dossiers_int
    On Error GoTo 0
    
    'rétablir les options d'excel
    Application.Calculation = mem1
    Application.EnableEvents = mem2
    Application.ScreenUpdating = mem3
    Application.DisplayAlerts = mem4

mem4 = Application.DisplayAlerts: Application.DisplayAlerts = False

Public Sub test_import_noms_dossiers()
Dim mem1 As Long, mem2 As Long, mem3 As Long
    'mémoriser/désactiver les options d'excel
    mem1 = Application.Calculation: Application.Calculation = xlCalculationManual
    mem2 = Application.EnableEvents: Application.EnableEvents = False
    mem3 = Application.ScreenUpdating: Application.ScreenUpdating = False
    mem4 = Application.DisplayAlerts: Application.DisplayAlerts = False

    'exécuter la macro
    On Error Resume Next
     test_import_noms_dossiers_int
    On Error GoTo 0

    'rétablir les options d'excel
    Application.Calculation = mem1
    Application.EnableEvents = mem2
    Application.ScreenUpdating = mem3
    Application.DisplayAlerts = False
End Sub


Private Sub test_import_noms_dossiers_int()
Dim i, j, k As Integer
Dim A As String
Dim listeFichiers() As String, iFichiers As Long

listeFichiers = ListerFichiersXls(ThisWorkbook.Path)

A = ActiveWorkbook.Name
j = Range("r_deb_tab").Row
For iFichiers = LBound(listeFichiers) To UBound(listeFichiers)
    If listeFichiers(iFichiers) <> ThisWorkbook.Path & "\" & ThisWorkbook.Name Then
        Cells(j, 1) = listeFichiers(iFichiers)
            With ActiveSheet
                .Hyperlinks.Add Anchor:=.Cells(j, 1), _
                Address:=.Cells(j, 1), _
                TextToDisplay:=.Cells(j, 1).Value
                .Hyperlinks(iFichiers + 1).ScreenTip = " VERS:" & .Cells(iFichiers + 6, 1).Value
            End With
        Workbooks.Open Cells(j, 1).Value, , True
        For k = 1 To Sheets.Count
            Workbooks(A).Sheets(1).Cells(j, 2).Value = Sheets(k).Name
            j = j + 1
        Next k
        ActiveWorkbook.Close
    End If
Next iFichiers


Application.ScreenUpdating = True
End Sub



Private Function ListerFichiersXls(folderPath As String) As Variant
Dim listeExtensions
listeExtensions = Array("xls", "xlsx", "xlsm")
ListerFichiersXls = Split(PrivateGetFileFromFolder(folderPath, listeExtensions, True), ";")
End Function


Private Function PrivateGetFileFromFolder(folderPath As String, fileExtensions, checkSubFolder As Boolean) As String
Dim myFso As Object, myFolder As Object, curFolder As Object, curFile As Object
Dim curExt As String, tmpTab() As String
Dim i As Integer
    Set myFso = CreateObject("Scripting.FileSystemObject")
    Set myFolder = myFso.GetFolder(folderPath)
    
    For Each curFile In myFolder.Files
        tmpTab = Split(curFile.Name, ".")
        curExt = tmpTab(UBound(tmpTab))
        For i = LBound(fileExtensions) To UBound(fileExtensions)
            If UCase(curExt) Like UCase(fileExtensions(i)) Then
                PrivateGetFileFromFolder = PrivateGetFileFromFolder & curFile.Path & ";"
                Exit For
            End If
        Next i
    Next curFile
    If checkSubFolder = True Then
        For Each curFolder In myFolder.SubFolders
            PrivateGetFileFromFolder = PrivateGetFileFromFolder & PrivateGetFileFromFolder(curFolder.Path, fileExtensions, checkSubFolder)
        Next curFolder
    End If
    
    Set myFolder = Nothing: Set myFso = Nothing
    If Right(PrivateGetFileFromFolder, 1) = ";" Then PrivateGetFileFromFolder = Left(PrivateGetFileFromFolder, Len(PrivateGetFileFromFolder) - 1)
End Function