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 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
| '==================================================================================
'
' Dans environnement VBA
' Outils | Références COCHER Microsoft Scripting Runtime
'
' Sinon VBScript téléchargeable à
' http://msdn.microsoft.com/library/de...ist/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 "Feuil1"
' 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 a ses besoins
'
'.............................................................
'Const NomFichierRch = "Classeur*"
'Const NomFichierRch = "FF+COXX060#X*"
'Const NomFichierRch = "####_#######_###_P*"
' 0027_XXXXXXX_YYY_P
Const NomFichierRch = "test*"
Const DossierRacine As String = "C:\Documents and Settings\Antoine\Bureau\macro"
Const NomFeuille As String = "test*"
Const TypeFichier As String = "XLS"
'.............................................................
'Const NomFichierRch = "NCR*"
'Const DossierRacine As String = "C:\NCR\NCR Report"
'Const NomFeuille As String = "template"
'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 = "E2173"
'.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:
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
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 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, True
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 |
Partager