Прокручивать файлы в папке с помощью VBA?

Я хотел бы пропустить файлы каталога с помощью vba в Excel 2010.

В цикле мне понадобится

  • имя файла и
  • дата форматирования файла.

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

Код, который работает, но waaaaaay слишком медленный (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 времени с помощью команды FileDateTime .
  2. Принимая во внимание другой ответ снизу, 20 секунд уменьшаются до менее 1 секунды.

6 Solutions collect form web for “Прокручивать файлы в папке с помощью VBA?”

Вот моя интерпретация как функция вместо:

 '####################################################################### '# LoopThroughFiles '# Function to Loop through files in current directory and return filenames '# Usage: LoopThroughFiles ActiveWorkbook.Path, "txt" 'inputDirectoryToScanForFile '# https://stackoverflow.com/questions/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 

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 

Кажется, Дир очень быстро.

 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 

Функция Dir – это путь, но проблема в том, что вы не можете использовать функцию Dir рекурсивно , как указано здесь, в нижней части .

Способ, которым я справился с этим, – использовать функцию Dir чтобы получить все подпапки для целевой папки и загрузить их в массив, а затем передать массив в функцию, которая рекурсирует.

Вот class, который я написал, который выполняет это, он включает в себя возможность поиска фильтров. ( Вам придется простить венгерскую нотацию, это было написано, когда все это ярость. )

 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 легко теряет фокус, когда я обрабатываю и обрабатываю файлы из других папок.

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

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

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

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

Попробуй!

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

 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 
  • Расширение формулы ячейки, разрешающей все ее ссылки (прецеденты)
  • Как объединить значения из нескольких строк в одну строку? Имейте модуль, но вам нужны переменные, объясняющие
  • Восстановить пароль защиты листа в Excel
  • Код VBA для скрытия или отображения строк на основе значения ячейки
  • В Excel 2013, где находятся инструменты Visual Basic (VBA), Макросы и AddIn?
  • Excel автоматически добавляет дополнительную строку с формулами для введенного количества лет
  • Как предотвратить повреждение общих файлов Excel?
  • VBA Macro для сортировки и применения условного форматирования к диапазону ячеек с динамическим числом строк
  • Как объединить значения из нескольких строк в одну строку с помощью модуля?
  • Экземпляр Excel VBA.
  • Как удалить или изменить фон заполняет все таблицы в документе Microsoft Word
  • Любая функция Excel, которая изменит строку?
  • Давайте будем гением компьютера.