使用VBA循环浏览文件夹中的文件？

6 回答

• 3

  当我处理和处理来自其他文件夹的文件时， Dir 函数很容易失去焦点 .

  我用组件 FileSystemObject 获得了更好的结果 .

  这里给出了完整的例子：

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

  不要忘记在Visual Basic编辑器中将引用设置为Microsoft Scripting Runtime（通过使用工具>引用）

  试试看！

  回复于 2024-04-23T22:05:25+08:00
• 21

  Dir函数是要走的路，但 the problem is that you cannot use the Dir function recursively ，如here, towards the bottom所述 .

  我处理这个问题的方法是使用 Dir 函数获取目标文件夹的所有子文件夹并将它们加载到一个数组中，然后将该数组传递给一个recurses函数 .

  这是我写的一个完成此任务的课程，它包括搜索过滤器的功能 . （你必须原谅匈牙利乐谱，这是在它风靡一时的时候写的 . ）

  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
  

  回复于 2024-04-23T22:05:25+08:00
• -1

  试试这个 . （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
  

  回复于 2024-04-23T22:05:25+08:00
• 30

  迪尔似乎很快 .

  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
  

  回复于 2024-04-23T22:05:25+08:00
• 218

  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
  

  回复于 2024-04-23T22:05:25+08:00
• 149

  以下是我作为函数的解释：

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

  回复于 2024-04-23T22:05:25+08:00