'==================================================================================
'
'   Dans environnement VBA
'   Outils | Références COCHER Microsoft Scripting Runtime
'
'   Sinon VBScript téléchargeable à
'   http://msdn.microsoft.com/library/default.asp?url=/downloads/list/webdev.asp
'
'==================================================================================
 
Option Explicit
 
Dim NbFichiers As Long
Dim DossierOk As String
 
'===============================================================================================
'   NomFichierRch   :   Fichier recherché, "*" si on les veut tous, "NCR*" si l'on ne veut que
'                       les fichiers débutant par NCR, voir aide en ligne sur opérateur LIKE
'                       ATTENTION sensible à la casse : minuscules/majuscules
'                       par exemple Classeur <> classeur
'
'   DossierRacine   :   "C:\...\Tst" dossier de départ pour la recherche des fichiers
'                       Dans Procédure btnImport_QuandClic modifer
'                           ListeFichiersDansDossier DossierOk, True
'                           en ListeFichiersDansDossier DossierOk, False
'                           si l'on ne veut pas de recherche dans les sous dossiers
'
'   NomFeuille      :   Si l'onglet des fichiers testés ne s'appelle pas NomFeuille  
'                       une erreur #REF! est incrite dans les cellules concernées
'                       de la feuille ShImport
'
'   TypeFichier     :   Type de fichiers que l'on traite, "XLS" pour les fichiers Excel
'                       Cela évitera des erreurs si le dossier contient par erreur ou hasard
'                       d'autres type de fichiers doc, pdf etc
'
'===============================================================================================
 
'   Pour TESTS sinon à Adapter par l'utilisateur à ses besoins
'.............................................................
'Const NomFichierRch = "Classeur*"
'Const NomFichierRch = "FF+COXX060#X*"
'   0027_XXXXXXX_YYY_P
Const NomFichierRch = "Classeur*"
Const DossierRacine As String = "C:\Transfert"
Const NomFeuille As String = "Feuil1"
Const TypeFichier As String = "XLS"
 
'===============================================================================================
'               Ici l'on ne traite q'une valeur située en A1
'               Pour infos j'ai ajouté une autre cellule Z3
'               Donc si l'on doit ajouter d'autres cellules à lire il
'               faudra aller modifier les procedures et fonctions suivantes
'                   Entete
'                   ListeFichiersDansDossier
'                   btnImport_QuandClic
'
'===============================================================================================
 
Private Sub Entete()
    With ShImport
        .Cells.Clear
        .Range("A3" ).Formula = "Fichier"
        .Range("B3" ).Formula = "Dossier"
        .Range("C3" ).Formula = "Date Création"
        .Range("D3" ).Formula = "Taille"
 
        '   A1  Z3
        .Range("E3" ).Formula = "A1"
        '.Range("E4" ).Formula = "Z3"
    End With
End Sub
 
Private Sub ListeFichiersDansDossier(ByVal NomDossierSource As String, ByVal InclureSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder, SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
Dim Extension As String
Dim r As Long, VerifNom As Boolean
 
    On Error GoTo erreurs
    Set FSO = New Scripting.FileSystemObject
    Set DossierSource = FSO.GetFolder(NomDossierSource)
 
    r = Range("A65536" ).End(xlUp).Row + 1
 
    For Each Fichier In DossierSource.Files
        Extension = UCase(FSO.GetExtensionName(Fichier))
        VerifNom = Fichier.Name Like NomFichierRch
        If Fichier.Name <> ThisWorkbook.Name Then
            If VerifNom Then
                If InStr(Fichier.Name, Chr(39)) > 0 Then Fichier.Name = Replace(Fichier.Name, Chr(39), "" )
                If UCase(TypeFichier) = Extension Then
                    With ShImport
                        .Cells(r, 1).Formula = Fichier.Name
                        .Cells(r, 2).Formula = Fichier.ParentFolder
                        .Cells(r, 3).Formula = Fichier.DateCreated
                        .Cells(r, 4).Formula = Fichier.Size
                        NbFichiers = NbFichiers + 1
                        r = r + 1
                    End With
                    Application.StatusBar = "Lecture noms : " & r
                End If
            End If
        End If
    Next Fichier
 
    If InclureSousDossiers Then
        For Each SousDossier In DossierSource.SubFolders
            ListeFichiersDansDossier SousDossier.Path, True
        Next SousDossier
        Set SousDossier = Nothing
    End If
 
    ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C5"
    ' Si cellule Z3 remplacer la ligne ci-dessus par
    'ActiveWorkbook.Names.Add Name:="Zone_de_Tri", RefersToR1C1:="=Import!R4C1:R" & (NbFichiers + 3) & "C6"
 
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
    Exit Sub
 
erreurs:
    If Err.Number = 76 Then
        MsgBox "Dossier inexistant" & vbCrLf & "Modifier dans VBA le chemin" & vbCrLf & "Const Dossier = " & DossierRacine, vbOKOnly, "Dossier des Fichiers"
    Else
        MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
    End If
End Sub
 
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, _
                                ByVal Feuille As String, ByVal Cellule As String)
Dim argument As String
    argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
    ExtraireValeur = ExecuteExcel4Macro(argument)
End Function
 
Public Sub btnImport_QuandClic()
Dim Debut As Variant
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String
 
    Debut = Time()
    Application.ScreenUpdating = False
    NbFichiers = 0
    NumeroLigne = 4
 
    Entete
    DossierOk = BackSlashDossier(DossierRacine)
 
    '   Recherche récursive ou non à partir de DossierRacine
    '   si recherche dans DossierRacine seulement
    '   remplacer ListeFichiersDansDossier DossierOk, True par
    '   ListeFichiersDansDossier DossierOk, False
 
    ListeFichiersDansDossier DossierOk, False
 
    For i = 1 To NbFichiers
        NomFichier = ShImport.Range("A" & NumeroLigne)
        NomDossier = BackSlashDossier(ShImport.Range("B" & NumeroLigne))
 
        With ShImport
            .Cells(NumeroLigne, 5) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A1" )
            '.Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "Z3" )
        End With
        NumeroLigne = NumeroLigne + 1
        Application.StatusBar = i & " / " & NbFichiers
    Next
 
    Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
 
    MepFinale
 
    Application.ScreenUpdating = True
End Sub
 
Private Function BackSlashDossier(ByVal TstDossier As String) As String
    If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
    BackSlashDossier = TstDossier
End Function
 
Private Sub MepFinale()
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    Rows("3:3" ).Font.Bold = True
    Columns("C:D" ).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
    Columns("A:E" ).Columns.AutoFit
    DispoBoutons
    Range("A1" ).Select
End Sub
 
Public Sub DispoBoutons()
Dim t As Range
    With ShImport
        .Activate
        .Rows(1).RowHeight = 12.75
        .Rows(2).RowHeight = 12.75
 
        Set t = .Cells(1, 3)
        With .Buttons("btnImport" )
            .Left = t.Left + 3
            .Top = t.Top + 5
            .Width = t.Width - 6
            .Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
        End With
    End With
End Sub
 
Private Sub Tri()
    Application.Goto Reference:="Zone_de_Tri"
    Selection.Sort Key1:=Range("A4" ), Order1:=xlAscending, Header:=xlNo
    Range("A1" ).Select
End Sub