VBA kullanarak bir klasördeki dosyalar arasında gezinmek mi istiyorsunuz?


236

Kullanarak bir dizin dosyaları arasında döngü istiyorum Excel 2010'da.

Döngüde ihtiyacım olacak:

  • dosya adı ve
  • dosyanın biçimlendirildiği tarih.

Klasör 50'den fazla dosya yoksa, iyi çalışan aşağıdaki kodlanmış, aksi takdirde gülünç yavaş (Ben> 10000 dosyaları ile klasörlerle çalışmak gerekir). Bu kodun tek sorunu, arama işleminin file.nameçok fazla zaman almasıdır.

Çalışan ancak waaaaaay çok yavaş olan kod (100 dosya başına 15 saniye):

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

Sorun çözüldü:

  1. Benim sorunum Dirbelirli bir şekilde (15000 dosyaları için 20 saniye) kullanarak ve komut kullanarak zaman damgası kontrol için aşağıdaki çözüm tarafından çözüldü FileDateTime.
  2. 20 saniyenin altındaki başka bir cevap dikkate alındığında 1 saniyeden daha azına indirilir.

VBA için başlangıç ​​zamanınız hala yavaş görünüyor. Application.ScreenUpdating = false kullanıyor musunuz?
Michiel van der Blonk

2
Sen eksik görünüyor codeSeti myObj = Yeni FileSystemObject
baldmosher

13
İnsanların FSO'yu "yavaş" demeye çabuk gelmelerini oldukça üzücü buluyorum, ama hiç kimse geç bağlı çağrılar yerine erken bağlamayı kullanarak kaçınabileceğiniz performans cezasından bahsetmiyor Object.
Mathieu Guindon

Yanıtlar:


46

İşte bunun yerine bir işlev olarak yorumum:

'#######################################################################
'# 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
Hiçbir şey geri verilmediğinde neden işlev? brettdj tarafından verilen cevapla aynı değil, bir fonksiyonun içine girmesi dışında
Shafeek

253

Dirjoker kartları alır, böylece testön tarafa filtre eklemek ve her dosyayı test etmekten kaçınmak için büyük bir fark yaratabilirsiniz.

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
HARİKA. Bu, çalışma süresini 20 saniyeden <1 saniyeye çıkardı. Bu büyük bir gelişme çünkü kod oldukça sık çalıştırılacak. TEŞEKKÜR EDERİM!!
tyrex

Bunun nedeni Do while ... döngüsünün while ... wend'den daha iyi olması olabilir. daha fazla bilgi için burada stackoverflow.com/questions/32728334/…
Hila DG

6
Ben bu iyileştirme seviyesi (20 - xxx kere) düşünmüyorum - Bence bu joker bir fark yaratıyor.
brettdj

DIR () Gizli dosyaları döndürmüyor gibi görünüyor.
hamish

@hamish, farklı dosya türlerini (gizli, sistem vb.) döndürmek için argümanını değiştirebilirsiniz - MS belgelerine bakın: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Dir çok hızlı gözüküyor.

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
Harika, çok teşekkür ederim. Dir kullanıyorum ama bu şekilde de kullanabileceğinizi bilmiyordum. Komuta ek olarak FileDateTimesorunum çözüldü.
tyrex

4
Hala bir soru. DIR en son dosyalardan başlayarak döngü yaparsa hızı ciddi şekilde artırabilirim. Bunu yapmanın bir yolu var mı?
tyrex

3
İkinci sorum aşağıdaki yorumdan brettdj'den çözüldü.
tyrex

notAncak Dir traverse the whole directory tree. Gerekirse: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com

Dir, diğer Dir komutları tarafından da kesilecektir, bu nedenle Dir içeren bir alt program çalıştırırsanız, orijinal alt öğenizde "sıfırlayabilir". Orijinal soruya göre FSO kullanılması bu sorunu ortadan kaldırır. EDIT: sadece @LimaNightHawk tarafından gönderilen yazı, aynı şey
baldmosher

26

Dir işlevi gitmenin yoludur, ancak sorun,Dir belirtildiği gibi işlevi yinelemeli olarak kullanamamanızdır. burada altta doğru .

Bunu ele alma şeklim, Dir , hedef klasörün tüm alt klasörlerini almak ve bunları bir diziye yüklemek, sonra diziyi geri alan bir işleve geçirmek için işlevi kullanmaktır.

İşte bunu başarmak için yazdığım bir sınıf, filtreleri arama yeteneğini içerir. ( Macar İşaretini affetmeniz gerekecek, bu tüm öfke olduğunda yazılmıştır. )

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

Sütunda bulunan dosyaları listelemek istersem, bunun bir uygulaması ne olabilir?
jechaviz

@jechaviz GetFileList yöntemi bir String dizesi döndürür. Muhtemelen dizi üzerinde yineleme yaparsınız ve öğeleri bir ListView'a veya bunun gibi bir şeye eklersiniz. Liste görünümünde öğelerin nasıl gösterileceğiyle ilgili ayrıntılar muhtemelen bu yayının kapsamı dışındadır.
LimaNightHawk

6

Dir diğer klasörlerden dosyaları işlediğimde ve işlediğimde işlev kolayca odağı kaybediyor.

Bileşenle daha iyi sonuçlar aldım FileSystemObject .

Tam örnek burada verilmiştir:

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

Visual Basic Düzenleyicisi'nde Microsoft Scripting Çalışma Zamanı'na başvuru ayarlamayı unutmayın (Araçlar> Başvurular'ı kullanarak)

Bir şans ver!


Teknik olarak bu, askerin kullandığı yöntemdir, referanslarını içermezler ve bu yöntemi yavaşlatır.
Marcucciboy2

-2

Bunu dene. ( 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
Sitemizi kullandığınızda şunları okuyup anladığınızı kabul etmiş olursunuz: Çerez Politikası ve Gizlilik Politikası.
Licensed under cc by-sa 3.0 with attribution required.