1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190
|
' Cocher références Microsoft ActiveX Data Objects 2.x Library
' Microsoft ADO Ext 2.x for DLL and Security
' Microsoft Scripting Runtime
Option Explicit
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim NbFichiers As Long
Dim NomFichierRch As String
Dim TabNoms() As String
Private Function BackSlashDossier(ByVal TstDossier As String) As String
If Right(TstDossier, 1) <> "\" Then TstDossier = TstDossier & "\"
BackSlashDossier = TstDossier
End Function
Private Sub Entete()
With ShImport
.Cells.Clear
.Range("A3") = "Fichier"
.Range("B3") = "Dossier"
.Range("C3") = "Date Création"
.Range("D3") = "Taille"
.Range("E3") = "Feuille"
.Range("F3") = "A3"
End With
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
Private Sub Import(sDossier As String)
Dim NumeroLigne As Long, i As Long
Dim NomFichier As String
Dim NomDossier As String
Dim NomFeuille As String
QueryPerformanceCounter Dep
Application.ScreenUpdating = False
NbFichiers = 0
NumeroLigne = 4
NomFichierRch = "*.xls"
Entete
sDossier = BackSlashDossier(sDossier)
ListeFichiersDansDossier sDossier, True
For i = 1 To NbFichiers
With ShImport
NomFichier = .Range("A" & NumeroLigne)
NomDossier = BackSlashDossier(.Range("B" & NumeroLigne))
NomFeuille = .Range("E" & NumeroLigne)
.Cells(NumeroLigne, 6) = ExtraireValeur(NomDossier, NomFichier, NomFeuille, "A3")
End With
NumeroLigne = NumeroLigne + 1
Application.StatusBar = i & " / " & NbFichiers
Next i
Mep
QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
With Application
.StatusBar = "Terminé : " & Format(((Fin - Dep) / Freq), "0.00 s")
.ScreenUpdating = True
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 r As Long, VerifNom As Boolean
Set FSO = New Scripting.FileSystemObject
Set DossierSource = FSO.GetFolder(NomDossierSource)
r = ShImport.Range("A" & Rows.Count).End(xlUp).Row + 1
For Each Fichier In DossierSource.Files
VerifNom = UCase(Fichier.Name) Like UCase(NomFichierRch) And Fichier.Name <> ThisWorkbook.Name
If VerifNom = True Then
With ShImport
.Cells(r, 1) = Fichier.Name
.Cells(r, 2) = Fichier.ParentFolder
.Cells(r, 3) = Fichier.DateCreated
.Cells(r, 4) = Fichier.Size
NomFeuilles .Cells(r, 2) & "\" & .Cells(r, 1)
.Cells(r, 5) = TabNoms(0)
NbFichiers = NbFichiers + 1
r = r + 1
End With
Application.StatusBar = "Lecture Infos : " & r
End If
Next Fichier
If InclureSousDossiers Then
For Each SousDossier In DossierSource.SubFolders
ListeFichiersDansDossier SousDossier.Path, True
Next SousDossier
End If
Set DossierSource = Nothing
Set FSO = Nothing
End Sub
Private Sub Mep()
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
With ShImport
.Rows("3:3").Font.Bold = True
.Columns("C:D").Select
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
Tri
With ShImport
.Columns("A:E").Columns.AutoFit
.Range("A1").Select
End With
End Sub
Private Sub NomFeuilles(sNomFichier As String)
Dim Cn As ADODB.Connection
Dim Feuille As ADOX.Table
Dim Cat As ADOX.Catalog
Dim strConn As String, i As Long
Erase TabNoms
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sNomFichier & ";" & _
"extended properties=""Excel 8.0;HDR=NO;IMEX=1"""
Set Cat = CreateObject("ADOX.Catalog")
Set Cn = CreateObject("ADODB.Connection")
Cn.Open strConn
Set Cat.ActiveConnection = Cn
i = 0
For Each Feuille In Cat.Tables
ReDim Preserve TabNoms(i)
TabNoms(i) = Replace(Feuille.Name, "$", "")
TabNoms(i) = Replace(TabNoms(i), "'", "")
i = i + 1
Next Feuille
Set Cat = Nothing
Cn.Close
End Sub
Sub SelDossier()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Sélectionner un Dossier"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
.ButtonName = "Sélection Dossier"
.Show
If .SelectedItems.Count > 0 Then
DoEvents
Import .SelectedItems(1)
End If
End With
End Sub
Private Sub Tri()
Dim LastRow As Long
With ShImport
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A3:F" & LastRow).Sort Key1:=.Range("A4"), Order1:=xlAscending, _
Key2:=.Range("B4"), Order2:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
End With
End Sub |
Partager