사용하여 디렉토리의 파일을 반복하고 싶습니다. VBA Excel 2010에서.
루프에서는 다음이 필요합니다.
- 파일 이름
- 파일이 포맷 된 날짜
폴더에 50 개 이상의 파일이 없으면 제대로 작동하는 다음을 코딩했습니다. 그렇지 않으면 엄청나게 느립니다 (10000 파일 이상의 폴더로 작업해야합니다). 이 코드의 유일한 문제는 조회하는 file.name데 시간이 많이 걸린다는 것입니다.
작동하지만 너무 느린 코드 (100 개 파일 당 15 초) :
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
문제 해결됨:
- 내 문제는
Dir특정 방식 (15000 파일의 경우 20 초)을 사용하고 명령을 사용하여 타임 스탬프를 확인하는 아래 솔루션으로 해결되었습니다FileDateTime. - 20 초 미만의 다른 응답을 고려하면 1 초 미만으로 줄어 듭니다.
답변
대신 함수로서의 해석은 다음과 같습니다.
'#######################################################################
'# LoopThroughFiles
'# Function to Loop through files in current directory and return filenames
'# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile
'# /programming/10380312/loop-through-files-in-a-folder-using-vba
'#######################################################################
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As String
Dim StrFile As String
'Debug.Print "in LoopThroughFiles. inputDirectoryToScanForFile: ", inputDirectoryToScanForFile
StrFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
Do While Len(StrFile) > 0
Debug.Print StrFile
StrFile = Dir
Loop
End Function
답변
Dir와일드 카드를 사용하므로 필터를 추가하고 test각 파일을 테스트하지 않아도 큰 차이를 만들 수 있습니다.
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은 매우 빠르다.
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
답변
Dir 함수는 갈 길이지만 , 문제는 Dir여기에 언급 된 것처럼 아래쪽 으로 함수를 재귀 적으로 사용할 수 없다는 것 입니다.
내가 처리 한 방법은 Dir함수 를 사용하여 대상 폴더의 모든 하위 폴더를 가져 와서 배열에로드 한 다음 배열을 재귀하는 함수에 전달하는 것입니다.
필자가 작성한 클래스는 필터를 검색하는 기능을 포함합니다. ( 당신은 헝가리어 표기법을 용서해야합니다. 이것은 모든 분노 일 때 쓰여졌습니다. )
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 다른 폴더의 파일을 처리하고 처리 할 때 기능이 쉽게 초점을 잃습니다.
component로 더 나은 결과를 얻었습니다 FileSystemObject.
전체 예는 다음과 같습니다.
http://www.xl-central.com/list-files-fso.html
도구> 참조를 사용하여 Visual Basic Editor에서 Microsoft Scripting Runtime에 대한 참조를 설정하는 것을 잊지 마십시오.
시도 해봐!
답변
이거 한번 해봐. ( 링크 )
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
답변
