Loop melalui file dalam folder menggunakan VBA?


236

Saya ingin mengulang melalui file-file direktori menggunakan di Excel 2010.

Dalam loop, saya perlu:

  • nama file, dan
  • tanggal di mana file diformat.

Saya telah memberi kode berikut ini yang berfungsi dengan baik jika folder tidak memiliki lebih dari 50 file, jika tidak sangat lambat (saya membutuhkannya untuk bekerja dengan folder dengan> 10.000 file). Satu-satunya masalah dari kode ini adalah bahwa operasi untuk mencari file.namemembutuhkan banyak waktu.

Kode yang berfungsi tetapi waaaaaay terlalu lambat (15 detik per 100 file):

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

Masalah terpecahkan:

  1. Masalah saya telah dipecahkan dengan menggunakan solusi di bawah ini dengan Dircara tertentu (20 detik untuk 15000 file) dan untuk memeriksa cap waktu menggunakan perintah FileDateTime.
  2. Memperhatikan jawaban lain dari bawah 20 detik dikurangi menjadi kurang dari 1 detik.

Waktu awal Anda tampaknya masih lambat untuk VBA. Apakah Anda menggunakan Application.ScreenUpdating = false?
Michiel van der Blonk

2
Anda tampaknya hilang codeSet MyObj = FileSystemObject Baru
baldmosher

13
Saya merasa agak sedih bahwa orang cepat menyebut FSO "lambat", tetapi tidak ada yang menyebutkan penalti kinerja yang bisa Anda hindari dengan hanya menggunakan ikatan awal alih-alih panggilan yang terikat akhir Object.
Mathieu Guindon

Jawaban:


46

Inilah interpretasi saya sebagai Fungsi Sebagai gantinya:

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

25
mengapa berfungsi, ketika tidak ada yang dikembalikan kembali? bukankah ini sama dengan jawaban yang diberikan oleh brettdj, kecuali itu dilampirkan dalam fungsi
Shafeek

253

Dirmengambil kartu liar sehingga Anda bisa membuat perbedaan besar dengan menambahkan filter testdi depan dan menghindari pengujian setiap file

Sub LoopThroughFiles()
    Dim StrFile As String
    StrFile = Dir("c:\testfolder\*test*")
    Do While Len(StrFile) > 0
        Debug.Print StrFile
        StrFile = Dir
    Loop
End Sub

29
BAGUS. Ini baru meningkatkan runtime dari 20 detik menjadi <1 detik. Itu peningkatan besar, karena kode akan dijalankan cukup sering. TERIMA KASIH!!
tyrex

Bisa jadi karena loop Do while ... lebih baik daripada while ... wend. info lebih lanjut di sini stackoverflow.com/questions/32728334/…
Hila DG

6
Saya tidak berpikir dengan tingkat peningkatan itu (20 - xxx kali) - Saya pikir ini adalah wildcard yang membuat perbedaan.
brettdj

DIR () sepertinya tidak mengembalikan file Tersembunyi.
hamish

@hamish, Anda dapat mengubah argumennya untuk mengembalikan berbagai jenis file (tersembunyi, sistem, dll.) - lihat dokumentasi MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Dir tampaknya sangat cepat.

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

3
Bagus, terima kasih banyak. Saya memang menggunakan Dir tetapi saya tidak tahu bahwa Anda juga bisa menggunakannya. Selain itu dengan perintah FileDateTimemasalah saya terpecahkan.
tyrex

4
Masih satu pertanyaan. Saya sangat dapat meningkatkan kecepatan jika DIR akan memulai dengan file yang paling baru. Apakah Anda melihat cara untuk melakukan ini?
tyrex

3
Pertanyaan saya yang terakhir telah diselesaikan oleh komentar di bawah ini dari brettdj.
tyrex

notNamun Dir akan melakukannya traverse the whole directory tree. Dalam kasus diperlukan: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com

Dir juga akan terganggu oleh perintah-perintah Dir lainnya, jadi jika Anda menjalankan subrutin yang berisi Dir, ia dapat "mengatur ulang" -nya di sub asli Anda. Menggunakan FSO sesuai pertanyaan awal menghilangkan masalah ini. EDIT: baru saja melihat posting oleh @LimaNightHawk di bawah ini, hal yang sama
baldmosher

26

Fungsi Dir adalah cara untuk pergi, tetapi masalahnya adalah Anda tidak dapat menggunakan Dirfungsi secara rekursif , seperti yang dinyatakan di sini, di bagian bawah .

Cara saya menangani ini adalah dengan menggunakan Dirfungsi untuk mendapatkan semua sub-folder untuk folder target dan memuatnya ke dalam array, kemudian meneruskan array ke fungsi yang berulang.

Inilah kelas yang saya tulis yang menyelesaikan ini, termasuk kemampuan untuk mencari filter. ( Anda harus memaafkan Notasi Hongaria, ini ditulis ketika itu semua kemarahan. )

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

Jika saya ingin membuat daftar file yang ditemukan di kolom, apa yang bisa menjadi implementasi dari ini?
jechaviz

@ jechaviz Metode GetFileList mengembalikan array String. Anda mungkin hanya akan mengulangi array dan menambahkan item ke ListView, atau sesuatu seperti itu. Detail tentang cara menampilkan item dalam tampilan daftar mungkin di luar cakupan posting ini.
LimaNightHawk

6

Dir fungsi kehilangan fokus dengan mudah ketika saya menangani dan memproses file dari folder lain.

Saya mendapatkan hasil yang lebih baik dengan komponen tersebut FileSystemObject.

Contoh lengkap diberikan di sini:

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

Jangan lupa untuk menetapkan referensi di Editor Visual Basic ke Microsoft Scripting Runtime (dengan menggunakan Tools> Referensi)

Cobalah!


Secara teknis ini adalah metode yang digunakan penanya, mereka hanya tidak memiliki referensi mereka termasuk yang akan memperlambat metode ini.
Marcucciboy2

-2

Coba yang ini. ( 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
Dengan menggunakan situs kami, Anda mengakui telah membaca dan memahami Kebijakan Cookie dan Kebijakan Privasi kami.
Licensed under cc by-sa 3.0 with attribution required.