获取文件夹和子文件夹中的所有文件

Question

我想做以下事情：

1. 提示用户选择文件夹
2. 遍历文件夹（以及子文件夹，如果存在）
3. 获取所有 .xlsx 文件
4. 从这些文件中获取特定列（都具有相同的结构）并合并该列中的数据

我获得了所有子文件夹和所有文件，但获得的数量是我应该获得的 5 倍。

L 列是我获取所有数据并插入相同主文件的位置（插入 L 列）。
我有 5 个文件 - 我应该在最后一列中获得 5 个项目，我只需在其中添加新文件夹和相同的文件（复制），所以现在我应该在最后一列中获得 10 个项目，而不是 50 个。

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range, r As Range
    Set Wb = ThisWorkbook: Wb.Sheets(2).Range("L:L").ClearContents
    Dim FSO As Object, fld As Object, Fil As Object
    Dim wbkCS As Workbook
    Dim FolderPath As String
    Dim fsoFile As Object
    Dim fsoFol As Object
    Dim fileName As String
    Dim sWb As Workbook
    Dim MatchingColumn As Range
    Dim MatchingRowNb As Long
    
    MsgBox "Choose a folder: "
    Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\Users\"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "No folder selected! Exiting script."
            Exit Sub
        End If
        FolderPath = .SelectedItems(1)
    End With
    If Right(FolderPath, 1) <> "\" Then
        FolderPath = FolderPath + "\"
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(FolderPath)
    If FSO.FolderExists(fld) Then
        For Each fsoFol In FSO.GetFolder(FolderPath).SubFolders
            For Each fsoFile In fsoFol.Files
                If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xlsx" Then
                    fileName = fsoFile.Name
                    Application.ScreenUpdating = False

                    MyDir = FolderPath 'fld
                    fileName = Dir(MyDir & "*.xlsx")
                    ChDir MyDir
                    Application.ScreenUpdating = False
                    Application.DisplayAlerts = False
                    Do While fileName <> ""
                        Set sWb = Workbooks.Open(fileName)
                        With sWb.Worksheets(2)
                            Rws = .Cells(Rows.Count, 12).End(xlUp).Row
                            Set Rng = Range(.Cells(5, 1), .Cells(Rws, 12))
                        End With
                        With Wb.Worksheets(2)
                            Set MatchingColumn = .Range(.Cells(5, 1), .Cells(.Rows.Count, 1).End(xlUp))
                            For Each r In Rng.Rows
                                If r.Cells(1, 1).Value2 <> vbNullString Then 'Ignoring empty rows   
                                    If r.Rows.Hidden = False Then
                                        'We find the row where the Ids matche
                                        MatchingRowNb = Application.Match(r.Cells(1, 1).Value2, MatchingColumn, False)
                                        'We add the current value in the cell with the new value comming from the other file
                                        .Cells(4 + MatchingRowNb, 12).Value2 = .Cells(4 + MatchingRowNb, 12).Value2 + r.Cells(1, 12).Value2
                                    End If
                                End If
                            Next
                        End With
                        sWb.Close SaveChanges:=True
                        Application.DisplayAlerts = True
                        fileName = Dir()
                    Loop
                End If
            Next
        Next
    End If
End Sub

Answer 1

您同时使用 FSO 和 Dir() 来循环文件，这就是为什么您会一遍又一遍地获取相同的文件。

当你的 sub 最终做了一堆事情时（特别是当一个事情嵌套在另一个事情中时，等等），那么最好考虑将它拆分，这样你就可以专注于给你带来问题的一件事情，而无需所有其他事情都“碍事”。

这是一个精简的版本来说明我的意思。它可以工作，但为了清楚起见，没有您的文件处理代码。

Option Explicit

Sub LoopThroughFolder()

    Dim Wb As Workbook, sWb As Workbook
    Dim FolderPath As String
    Dim colFiles As Collection, f

    'get a folder
    FolderPath = ChooseFolder()
    If Len(FolderPath) = 0 Then
        MsgBox "No folder selected: exiting"
        Exit Sub
    End If
    
    'find all excel files in subfolders of that folder
    Set colFiles = FileMatches(FolderPath, "*.xlsx")
    If colFiles.Count = 0 Then
        MsgBox "No xlsx files found"
        Exit Sub
    End If
    
    Set Wb = ThisWorkbook
    Wb.Sheets(2).Range("L:L").ClearContents
    
    'loop over the files we found
    For Each f In colFiles
        Set sWb = Workbooks.Open(f.Path)
        'process the file here
        sWb.Close SaveChanges:=True
    Next f
    
End Sub

Function ChooseFolder() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Choose a folder"
        .InitialFileName = "C:\Users\"
        .AllowMultiSelect = False
        If .Show = -1 Then
            ChooseFolder = .SelectedItems(1)
            If Right(ChooseFolder, 1) <> "\" Then _
                       ChooseFolder = ChooseFolder + "\"
        End If
    End With
End Function

'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function FileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        For Each f In fldr.Files 'get files in folder
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then 'get subfolders for processing?
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set FileMatches = colFiles
End Function