Lặp qua các tập tin trong một thư mục bằng VBA?

Tôi muốn lặp qua các tập tin của một thư mục bằng cách sử dụng vba trong Excel 2010.

Trong vòng lặp, tôi sẽ cần:

• tên tệp và
• ngày mà tập tin được định dạng.

Tôi đã mã hóa những thứ sau đây hoạt động tốt nếu thư mục không có quá 50 tệp, nếu không thì nó rất chậm (tôi cần nó để làm việc với các thư mục có> 10000 tệp). Vấn đề duy nhất của mã này là thao tác tra cứu file.namemất rất nhiều thời gian.

Mã hoạt động nhưng waaaaaay quá chậm (15 giây trên 100 tệp):

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

Vấn đề được giải quyết:

1. Vấn đề của tôi đã được giải quyết bằng giải pháp bên dưới bằng cách sử dụng Dirmột cách cụ thể (20 giây cho 15000 tệp) và để kiểm tra dấu thời gian bằng lệnh FileDateTime.
2. Có tính đến một câu trả lời khác từ dưới 20 giây được giảm xuống dưới 1 giây.

Đây là giải thích của tôi như là một chức năng thay thế:

'#######################################################################
'# 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

Dirmất các thẻ hoang dã để bạn có thể tạo ra sự khác biệt lớn khi thêm bộ lọc testlên trước và tránh kiểm tra từng tệp

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 dường như rất nhanh.

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

Hàm Dir là con đường để đi, nhưng vấn đề là bạn không thể sử dụng Dirhàm đệ quy , như đã nêu ở đây, về phía dưới .

Cách mà tôi đã xử lý việc này là sử dụng Dirhàm để lấy tất cả các thư mục con cho thư mục đích và tải chúng vào một mảng, sau đó chuyển mảng vào một hàm đệ quy.

Đây là một lớp mà tôi đã viết để thực hiện điều này, nó bao gồm khả năng tìm kiếm các bộ lọc. ( Bạn sẽ phải tha thứ cho Ký hiệu Hungary, điều này được viết khi nó là tất cả cơn thịnh nộ. )

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 Chức năng mất tập trung dễ dàng khi tôi xử lý và xử lý tệp từ các thư mục khác.

Tôi đã nhận được kết quả tốt hơn với các thành phần FileSystemObject.

Ví dụ đầy đủ được đưa ra ở đây:

http://www.xl-central.com/list-files-fso.html

Đừng quên đặt tham chiếu trong Trình soạn thảo Visual Basic thành Microsoft Scripting Runtime (bằng cách sử dụng Công cụ> Tài liệu tham khảo)

Hãy thử một lần!

Hãy thử cái này ( LIÊN KẾT )

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