如何将不同文件夹内的同名.txt文件合并为单个文件？

要实现跨文件夹同名.txt文件合并，修改后的完整代码如下，已修复原代码的路径读取bug，新增子文件夹遍历和同名内容聚合逻辑：

Sub CombineSameNameTextFiles()
    Dim lFile As Long
    Dim sFile As String
    Dim sPath As String
    Dim sLine As String
    Dim dict As Object
    Dim fileFullPath As String
    Dim fileNameOnly As String
    Dim allTxtFiles As Collection
    Dim vItem As Variant
    Dim outputFolder As String
    
    ' 初始化字典用于归类同名文件
    Set dict = CreateObject("Scripting.Dictionary")
    Set allTxtFiles = New Collection
    
    ' 选择要遍历的根文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "请选择包含TXT文件的根文件夹"
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> Application.PathSeparator Then
                sPath = sPath & Application.PathSeparator
            End If
        Else
            Exit Sub
        End If
    End With
    
    ' 选择合并后文件的输出文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "请选择合并后文件的输出文件夹"
        If .Show Then
            outputFolder = .SelectedItems(1)
            If Right(outputFolder, 1) <> Application.PathSeparator Then
                outputFolder = outputFolder & Application.PathSeparator
            End If
        Else
            Exit Sub
        End If
    End With
    
    ' 递归获取根目录下所有TXT文件全路径
    Call GetAllTxtFiles(sPath, allTxtFiles)
    
    ' 遍历所有TXT文件，按文件名聚合内容
    For Each vItem In allTxtFiles
        fileFullPath = CStr(vItem)
        fileNameOnly = Mid(fileFullPath, InStrRev(fileFullPath, Application.PathSeparator) + 1)
        
        lFile = FreeFile
        Open fileFullPath For Input As #lFile
        Do Until EOF(lFile)
            Line Input #lFile, sLine
            ' 同文件名内容追加
            If dict.Exists(fileNameOnly) Then
                dict(fileNameOnly) = dict(fileNameOnly) & vbNewLine & sLine
            Else
                dict.Add fileNameOnly, sLine
            End If
        Loop
        Close lFile
    Next
    
    ' 输出合并后的文件：每个同名文件单独输出
    For Each vItem In dict.Keys
        lFile = FreeFile
        Open outputFolder & CStr(vItem) For Output As #lFile
        Print #lFile, dict(vItem)
        Close lFile
    Next
    
    ' --- 如果需要把所有内容合并到单个总文件，注释上面的输出代码，启用下面的代码 ---
    ' Dim vNewFile As Variant
    ' vNewFile = Application.GetSaveAsFilename("CombinedFile.txt", "Text files (*.txt), *.txt", , "请输入总合并文件名")
    ' If TypeName(vNewFile) = "Boolean" Then Exit Sub
    ' lFile = FreeFile
    ' Open CStr(vNewFile) For Output As #lFile
    ' For Each vItem In dict.Items
    '     Print #lFile, vItem & vbNewLine
    ' Next
    ' Close lFile
    
    MsgBox "合并完成，共处理" & dict.Count & "类同名文件", vbInformation
End Sub

' 递归遍历所有子文件夹获取TXT文件路径
Sub GetAllTxtFiles(ByVal currentPath As String, ByRef fileCollection As Collection)
    Dim sFile As String
    Dim subFolder As String
    Dim subFolders As Collection
    Dim vSub As Variant
    
    Set subFolders = New Collection
    
    ' 先收集当前文件夹下的所有TXT文件
    sFile = Dir(currentPath & "*.txt")
    Do While Len(sFile) > 0
        fileCollection.Add currentPath & sFile
        sFile = Dir()
    Loop
    
    ' 收集当前文件夹下的所有子文件夹
    subFolder = Dir(currentPath, vbDirectory)
    Do While Len(subFolder) > 0
        If subFolder <> "." And subFolder <> ".." Then
            If (GetAttr(currentPath & subFolder) And vbDirectory) = vbDirectory Then
                subFolders.Add currentPath & subFolder & Application.PathSeparator
            End If
        End If
        subFolder = Dir()
    Loop
    
    ' 递归遍历子文件夹
    For Each vSub In subFolders
        Call GetAllTxtFiles(CStr(vSub), fileCollection)
    Next
End Sub

关键调整说明 #

• 新增递归遍历逻辑：通过GetAllTxtFiles子程序遍历选中根目录下所有层级的子文件夹，不会遗漏不同文件夹下的同名文件
• 新增字典聚合逻辑：以文件名为键存储对应内容，自动把所有同名文件的内容拼接到一起，无需手动归类
• 修复原代码bug：原代码读取文件时未拼接路径，会出现文件找不到的报错，修改后直接用全路径读取文件
• 支持两种输出模式：默认每个同名文件单独输出合并后的版本，也可切换为所有内容汇总到单个总文件，按需调整注释即可

使用提示：运行代码时需要启用宏，若提示字典对象未找到，可在VBA编辑器的工具-引用中勾选「Microsoft Scripting Runtime」。

内容的提问来源于stack exchange，提问作者Wealthless