Перебирать файлы в папке с помощью 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
Похоже, вы отсутствуете codeSet 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 ... лучше, чем while ... wend. Более подробная информация здесь stackoverflow.com/questions/32728334/…
Hila DG

6
Я не думаю, что по этому уровню улучшения (20 - ххх раз) - я думаю, что подстановочный знак имеет значение.
brettdj

DIR () не возвращает скрытые файлы.
Хэмиш

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

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
Отлично! Большое спасибо. Я использую Dir, но я не знал, что вы можете использовать его и таким образом. Кроме того, с командой FileDateTimeмоя проблема решена.
Tyrex

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 в соответствии с первоначальным вопросом устраняет эту проблему. РЕДАКТИРОВАТЬ: только что видел пост @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 Метод GetFileList возвращает массив строк. Вы, вероятно, просто перебираете массив и добавляете элементы в ListView или что-то в этом роде. Подробности того, как отображать элементы в списке, вероятно, выходят за рамки этого поста.
LimaNightHawk

6

Dir функция легко теряет фокус при обработке и обработке файлов из других папок.

Я получил лучшие результаты с компонентом FileSystemObject.

Полный пример приведен здесь:

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

Не забудьте установить ссылку в редакторе Visual Basic на Microsoft Scripting Runtime (с помощью Сервис> Ссылки)

Попробуйте!


Технически это метод, который использует аскер, у них просто нет включенных ссылок, которые замедляют этот метод.
Marcucciboy2

-2

Попробуй это. ( ССЫЛКА )

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.