Boucle à travers des fichiers dans un dossier en utilisant VBA?
je voudrais boucler les fichiers d'un répertoire en utilisant vba dans Excel 2010.
Dans la boucle, j'ai besoin d'
- "1519110920 le nom du fichier, et
- date à laquelle le fichier a été formaté.
j'ai codé ce qui suit qui fonctionne bien si le dossier n'a pas plus de 50 fichiers, sinon il est ridiculement lent (j'en ai besoin pour travailler avec des dossiers avec >10000 fichiers). Le seul problème de ce code est que l'opération de recherche file.name
prend énormément de temps.
Code qui fonctionne mais est waaaaay trop lent (15 secondes pour 100 fichiers):
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("c:testfolder")
For Each file In MySource.Files
If InStr(file.name, "test") > 0 Then
MsgBox "found"
Exit Sub
End If
Next file
End Sub
Problème résolu:
- mon problème a été résolu par la solution ci-dessous en utilisant
Dir
d'une manière particulière (20 secondes pour 15000 fichiers) et pour vérifier l'horodatage à l'aide de la commandeFileDateTime
. - compte tenu d'une autre réponse de moins de 20 secondes sont réduites à moins d'une seconde.
6 réponses
Voici mon interprétation comme une fonction à la place:
'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# /q/loop-through-files-in-a-folder-using-vba-74764/"in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile
StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
Debug.Print StrFile
StrFile = Dir
Loop
End Function
Dir
prend des jokers donc vous pourriez faire une grande différence en ajoutant le filtre pour test
à l'avant et en évitant de tester chaque fichier
Sub LoopThroughFiles()
Dim StrFile As String
StrFile = Dir("c:\testfolder\*test*")
Do While Len(StrFile) > 0
Debug.Print StrFile
StrFile = Dir
Loop
End Sub
Dir semble être très rapide.
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("c:\testfolder\")
While (file <> "")
If InStr(file, "test") > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
la fonction Dir est la voie à suivre, mais le problème est que vous ne pouvez pas utiliser la fonction Dir
de façon récursive , comme indiqué ici, vers le bas .
La façon dont j'ai géré cela est d'utiliser la Dir
fonction pour obtenir tous les sous-dossiers du dossier cible et de les charger dans un tableau, puis passer le tableau dans une fonction qui se répète.
voici un cours que j'ai écrit cela comprend la capacité de rechercher des filtres. ( Tu pardonneras la Notation hongroise, cette lettre a été écrite quand il était à la mode. )
Private m_asFilters() As String
Private m_asFiles As Variant
Private m_lNext As Long
Private m_lMax As Long
Public Function GetFileList(ByVal ParentDir As String, Optional ByVal sSearch As String, Optional ByVal Deep As Boolean = True) As Variant
m_lNext = 0
m_lMax = 0
ReDim m_asFiles(0)
If Len(sSearch) Then
m_asFilters() = Split(sSearch, "|")
Else
ReDim m_asFilters(0)
End If
If Deep Then
Call RecursiveAddFiles(ParentDir)
Else
Call AddFiles(ParentDir)
End If
If m_lNext Then
ReDim Preserve m_asFiles(m_lNext - 1)
GetFileList = m_asFiles
End If
End Function
Private Sub RecursiveAddFiles(ByVal ParentDir As String)
Dim asDirs() As String
Dim l As Long
On Error GoTo ErrRecursiveAddFiles
'Add the files in 'this' directory!
Call AddFiles(ParentDir)
ReDim asDirs(-1 To -1)
asDirs = GetDirList(ParentDir)
For l = 0 To UBound(asDirs)
Call RecursiveAddFiles(asDirs(l))
Next l
On Error GoTo 0
Exit Sub
ErrRecursiveAddFiles:
End Sub
Private Function GetDirList(ByVal ParentDir As String) As String()
Dim sDir As String
Dim asRet() As String
Dim l As Long
Dim lMax As Long
If Right(ParentDir, 1) <> "\" Then
ParentDir = ParentDir & "\"
End If
sDir = Dir(ParentDir, vbDirectory Or vbHidden Or vbSystem)
Do While Len(sDir)
If GetAttr(ParentDir & sDir) And vbDirectory Then
If Not (sDir = "." Or sDir = "..") Then
If l >= lMax Then
lMax = lMax + 10
ReDim Preserve asRet(lMax)
End If
asRet(l) = ParentDir & sDir
l = l + 1
End If
End If
sDir = Dir
Loop
If l Then
ReDim Preserve asRet(l - 1)
GetDirList = asRet()
End If
End Function
Private Sub AddFiles(ByVal ParentDir As String)
Dim sFile As String
Dim l As Long
If Right(ParentDir, 1) <> "\" Then
ParentDir = ParentDir & "\"
End If
For l = 0 To UBound(m_asFilters)
sFile = Dir(ParentDir & "\" & m_asFilters(l), vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem)
Do While Len(sFile)
If Not (sFile = "." Or sFile = "..") Then
If m_lNext >= m_lMax Then
m_lMax = m_lMax + 100
ReDim Preserve m_asFiles(m_lMax)
End If
m_asFiles(m_lNext) = ParentDir & sFile
m_lNext = m_lNext + 1
End If
sFile = Dir
Loop
Next l
End Sub
Dir
fonction perd la mise au point facilement lorsque je manipule et traite des fichiers à partir d'autres dossiers.
j'ai obtenu de meilleurs résultats avec le composant FileSystemObject
.
exemple complet est donné ici:
http://www.xl-central.com/list-files-fso.html
N'oubliez pas de définir une référence dans L'éditeur Visual Basic à Microsoft Scripting Runtime (en utilisant des Outils > Références)
essayez!
essayez celui-ci. ( LINK )
Private Sub CommandButton3_Click()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
xWs.Copy
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub