Question

我目前有一个宏来检查excel文件的文件夹，并运行一些格式类型调整（添加列等）。

问题是它只允许我选择一个文件夹并在那里签到。我需要检查的文件夹很多，它们都存在于同一目录中。

即使将AllowMultiSelect调整为True，我也无法选择多个要签入的文件夹。如何修改此代码以便允许我选择目录中的所有文件夹？

Sub Button1_Click()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog


  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

  NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

  myExtension = "*.xls"

  myFile = Dir(myPath & myExtension)

  Do While myFile <> ""
      Set wb = Workbooks.Open(fileName:=myPath & myFile)

      DoEvents

        'Formatting adjustments etc go here

      wb.Close SaveChanges:=True

      DoEvents

      myFile = Dir

  Loop

  MsgBox "Complete."



End Sub

Answer 1

我认为我提出了一些比手动选择所有文件夹更好的解决方案。你说你的所有文件都在某个目录中，里面有一些子文件夹。使用下面的代码，您将遍历您选择的文件夹中的每个文件。您将在格式化子中存储每个格式化逻辑。

Sub Button1_Click()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog

    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
        .Title = "Select A Target Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        MyPath = .SelectedItems(1)
    End With


    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Call GetAllFiles(MyPath, objFSO)
    Call GetAllFolders(MyPath, objFSO)

  MsgBox "Complete."

NextCode:
End Sub
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object

    Set objFolder = objFSO.GetFolder(strPath)
    For Each objFile In objFolder.Files
            Formatting (objFile.Path)
    Next objFile
End Sub

Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object

    Set objFolder = objFSO.GetFolder(strFolder)
    For Each objSubFolder In objFolder.subfolders
        Call GetAllFiles(objSubFolder.Path, objFSO)
        Call GetAllFolders(objSubFolder.Path, objFSO)
    Next objSubFolder
End Sub

Sub Formatting(strFile As String)
Dim wb As Workbook
    If Right(strFile, 3) = "xls" Then
        Set wb = Workbooks.Open(Filename:=MyPath & myFile)
        DoEvents

        'Formatting adjustments etc go here

        wb.Close SaveChanges:=True
        DoEvents
        myFile = Dir
    End If
End Sub

Answer 2

这个概念怎么样？您递归地映射到所有文件夹中的所有文件，并创建整个文件夹结构的架构。然后，根据每个文件夹路径控制每个文件。

Option Explicit

Sub ListAllFiles()
        searchForFiles "C:\your_path_here\", "writefilestosheet", "*.*", True, True
    End Sub

    Sub processOneFile(ByVal aFilename As String)
        Debug.Print aFilename
    End Sub

    Sub writeFilesToSheet(ByVal aFilename As String)
        With ActiveSheet
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename
            End With
    End Sub


    Private Sub processFiles(ByVal DirToSearch As String, _
                ByVal ProcToCall As String, _
                ByVal FileTypeToFind As String)
            Dim aFile As String
            aFile = Dir(DirToSearch & FileTypeToFind)
            Do While aFile <> ""
                Application.Run ProcToCall, DirToSearch & aFile
                aFile = Dir()
                Loop
    End Sub

    Private Sub processSubFolders(ByVal DirToSearch As String, _
                ByVal ProcToCall As String, _
                ByVal FileTypeToFind As String, _
                ByVal SearchSubDir As Boolean, _
                ByVal FilesFirst As Boolean)

    Dim aFolder As String, SubFolders() As String

    ReDim SubFolders(0)

    aFolder = Dir(DirToSearch, vbDirectory)

        Do While aFolder <> ""

            If aFolder <> "." And aFolder <> ".." Then

                If (GetAttr(DirToSearch & aFolder) And vbDirectory) _
                        = vbDirectory Then
                    SubFolders(UBound(SubFolders)) = aFolder
                    ReDim Preserve SubFolders(UBound(SubFolders) + 1)
                    End If
                    End If
                aFolder = Dir()
                Loop

            If UBound(SubFolders) <> LBound(SubFolders) Then
                Dim i As Long
                For i = LBound(SubFolders) To UBound(SubFolders) - 1
                    searchForFiles _
                        DirToSearch & SubFolders(i), _
                        ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst
                    Next i
                End If

        End Sub

    Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _
            Optional ByVal FileTypeToFind As String = "*.*", _
            Optional ByVal SearchSubDir As Boolean = False, _
            Optional ByVal FilesFirst As Boolean = False)
        On Error GoTo ErrXIT
        If Right(DirToSearch, 1) <> Application.PathSeparator Then _
            DirToSearch = DirToSearch & Application.PathSeparator

    If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind
    If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _
        FileTypeToFind, SearchSubDir, FilesFirst

        If Not FilesFirst Then _
            processFiles DirToSearch, ProcToCall, FileTypeToFind
        Exit Sub
    ErrXIT:
        MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")"
        Exit Sub
    End Sub

Excel VBA：选择多个文件夹

2 个答案: