'==================================================================================
'
'   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
 
Const NomFichierRch = "Classeur*"
Const DossierRacine As String = "C:\Faq\FaqVba\Exemples"
Const NomFeuille As String = "Feuil1"
Const TypeFichier As String = "XLS"
 
Public Sub btnImport_QuandClic()
Dim Debut As Variant
Dim i As Long
Dim NomFichier As String
Dim NomDossier As String
 
    Debut = Time()
    Application.ScreenUpdating = False
    NbFichiers = 0
 
    DossierOk = BackSlashDossier(DossierRacine)
 
    ListeFichiersDansDossier DossierOk, True
 
    Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
    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 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 ' Feuille recueillant les données
                        .Cells(r, 1)= Fichier.Name
                        .Cells(r, 2)= Fichier.ParentFolder
                        .Cells(r, 3)= Fichier.DateCreated
                        .Cells(r, 4)= 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
 
    Set Fichier = Nothing
    Set DossierSource = Nothing
    Set FSO = Nothing
    Exit Sub
 
erreurs:
    Select Case Err.Number
        Case 76
            MsgBox "Dossier inexistant" & vbCrLf & "Modifier dans VBA le chemin" & vbCrLf & "Const Dossier = " & DossierRacine, vbOKOnly, "Dossier des Fichiers"
        Case Else
            MsgBox Err.Number & vbCrLf & vbCrLf & Err.Description
    End Select
End Sub

If Fichier.DateLastModified >= ShImport.Range("F1" ) Then