Прокручуйте файли в папці за допомогою VBA?


236

Я хотів би переглядати файли каталогу за допомогою в Excel 2010.

У циклі мені знадобляться:

  • ім'я файлу та
  • дата, коли файл було відформатовано.

Я зашифрував наступне, що добре працює, якщо в папці не більше 50 файлів, інакше це смішно повільно (мені це потрібно для роботи з папками з> 10000 файлами). Єдиною проблемою цього коду є те, що операція по пошуку file.nameзаймає надзвичайно багато часу.

Код, який працює, але занадто повільний (15 секунд на 100 файлів):

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

Проблема вирішена:

  1. Моя проблема була вирішена рішенням нижче, використовуючи Dirпевний спосіб (20 секунд для 15000 файлів) та перевірку позначки часу за допомогою команди FileDateTime.
  2. Враховуючи іншу відповідь знизу, 20 секунд скорочуються менше ніж на 1 секунду.

Ваш початковий час все ще здається повільним для VBA. Ви використовуєте Application.ScreenUpdating = false?
Міхель ван дер Блонк

2
Ви, здається, codeбракуєте. Встановити MyObj = New FileSystemObject
baldmosher

13
Мені здається сумно, що люди швидко називають FSO "повільним", але ніхто не згадує штрафну ефективність, якої ви могли уникнути, просто скориставшись ранньою прив'язкою замість пізніх викликів Object.
Матьє Гіндон

Відповіді:


46

Ось моя інтерпретація як функція:

'#######################################################################
'# 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
навіщо функціонувати, коли нічого не повертається назад? це не те саме, що відповідь, дану brettdj, за винятком того, що вона вкладена у функцію
Shafeek

253

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

29
ВЕЛИКИЙ. Це просто покращило час виконання з 20 секунд до <1 секунди. Це велике поліпшення, оскільки код буде працювати досить часто. СПАСИБІ!!
tyrex

Це може бути тому, що цикл "Do while ..." краще тоді, поки ... wend. більше інформації тут stackoverflow.com/questions/32728334/…
Hila DG

6
Я не думаю, що цей рівень поліпшення (20 - xxx разів) - я думаю, що його підстановка має значення.
brettdj

Здається, DIR () не повертає приховані файли.
Гаміш

@hamish, ви можете змінити його аргумент, щоб повернути різні типи файлів (приховані, системні тощо) - див. документацію на MS: docs.microsoft.com/en-us/office/vba/language/reference/…
Vincent

158

Дір, здається, дуже швидко.

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
Чудово, дуже дякую Я використовую Дір, але я не знав, що ви можете використовувати його і таким чином. Окрім команди, FileDateTimeмоя проблема вирішена.
тирекс

4
Ще одне питання. Я міг би значно підвищити швидкість, якщо DIR буде циклічно починати з останніх файлів. Ви бачите якийсь спосіб зробити це?
tyrex

3
Моє останнє запитання було вирішено коментарем нижче від brettdj.
tyrex

Дір буде, notоднак traverse the whole directory tree. У випадку необхідності: analystcave.com/vba-dir-function-how-to-traverse-directories/…
AnalystCave.com

Також Dir буде перерваний іншими командами Dir, тому якщо ви запустите підпрограму, що містить Dir, вона може "скинути" її у вихідний підрозділ. Використання FSO відповідно до оригінального питання усуває цю проблему. EDIT: щойно побачив повідомлення від @LimaNightHawk нижче, те саме
baldmosher

26

Функція 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

Якщо я хотів би перерахувати файли, знайдені в стовпці, що може бути реалізацією цього?
jechaviz

@jechaviz Метод GetFileList повертає масив String. Ви, ймовірно, просто повторіть масив і додасте елементи до ListView або щось подібне. Деталі про те, як показувати елементи в перегляді списку, ймовірно, виходять за межі цієї публікації.
LimaNightHawk

6

Dir Функція легко втрачає фокус при обробці та обробці файлів з інших папок.

Я отримав кращі результати з компонентом FileSystemObject.

Повний приклад наведено тут:

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

Не забудьте встановити посилання у візуальному базовому редакторі на час виконання сценарію Microsoft (за допомогою інструментів> Список літератури)

Спробувати!


Технічно це метод, який використовує запитувач, вони просто не містять посилань, які б сповільнили цей метод.
Marcucciboy2

-2

Спробуйте це. ( 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
Використовуючи наш веб-сайт, ви визнаєте, що прочитали та зрозуміли наші Політику щодо файлів cookie та Політику конфіденційності.
Licensed under cc by-sa 3.0 with attribution required.