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
| 'A déclarer pour la mesure du temps d'exécution
Public Declare Function GetTickCount& Lib "kernel32" ()
Sub SelectionDuRepertoire()
Dim fd As FileDialog, NC As Variant, Chemin As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
If .Show = -1 Then
For Each NC In .SelectedItems
Chemin = Left(NC, Len(NC) - InStr(StrReverse(NC), "\"))
Next
Else
MsgBox "Chemin non trouvé"
Exit Sub
End If
End With
ListerUnRepertoireAvecDir Chemin
ListerUnRepertoireAvecFileSearch Chemin
ListerUnRepertoireAvecFso Chemin
End Sub
'Public Declare Function GetTickCount& Lib "kernel32" ()
Sub TempsEcoulé(NbF As Integer, duree As Double, NomSub As String)
Dim mn As Integer, ms As Integer, sd As Integer, tps As String
mn = Int(duree / 1000 / 60)
sd = Int((duree / 1000) - (mn * 60))
ms = duree - (sd * 1000) - (mn * 1000 * 60)
tps = mn & " mn " & sd & " s " & ms & " millisecondes"
MsgBox "Procédure " & NomSub & vbCr & "Nombre de fichiers du répertoire " & NbF & vbCr & _
"Temps écoulé : " & tps
End Sub
Sub ListerUnRepertoireAvecFileSearch(Chemin As String)
Dim fs As Variant
Dim tablo()
Dim Depart As Double, duree As Double
Depart = GetTickCount&
Set fs = Application.FileSearch
With fs
.LookIn = Chemin
.FileType = msoFileTypeExcelWorkbooks
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
'Workbooks.Open .FoundFiles(i)
ReDim Preserve tablo(i)
tablo(i) = .FoundFiles(i)
Next i
End If
End With
duree = GetTickCount& - Depart
Dim NomSub As String
NomSub = "ListerUnRepertoireAvecFileSearch"
TempsEcoulé UBound(tablo), duree, NomSub
End Sub
'Procédure VBA Excel
Sub ListerUnRepertoireAvecDir(Chemin As String)
Dim NomFich As String, tablo()
Dim Depart As Double, duree As Double
Depart = GetTickCount&
NomFich = Dir(Chemin & "\", vbNormal)
Do While NomFich <> ""
'Workbooks.Open chemin & NomFich
'DoEvents
i = i + 1
ReDim Preserve tablo(i)
tablo(i) = Chemin & NomFich
NomFich = Dir()
Loop
duree = GetTickCount& - Depart
Dim NomSub As String
NomSub = "ListerUnRepertoireAvecDir"
TempsEcoulé UBound(tablo), duree, NomSub
End Sub
'Nécessite la validation de la référence "Microsoft Scripting Runtime"
Sub ListerUnRepertoireAvecFso(Chemin As String)
On Error Resume Next
Dim FSO As Scripting.FileSystemObject
If Err <> 0 Then
MsgBox "Nécessite la validation de la référence " & vbCr & _
"Microsoft Scripting Runtime"
Exit Sub
End If
Dim Rep As Scripting.Folder
Dim Fich As Scripting.File
Dim tablo()
Dim Depart As Double, duree As Double
Depart = GetTickCount&
Set FSO = New Scripting.FileSystemObject
Set Rep = FSO.GetFolder(Chemin)
For Each Fich In Rep.Files
If Right(Fich.Name, 4) = ".xls" Then
'Workbooks.Open chemin & Fich.Name
'DoEvents
i = i + 1
ReDim Preserve tablo(i)
tablo(i) = Fich.Name
End If
Next
duree = GetTickCount& - Depart
Dim NomSub As String
NomSub = "ListerUnRepertoireAvecFso"
TempsEcoulé UBound(tablo), duree, NomSub
End Sub |
Partager