当前位置：首页 > news >正文

VBA使用fso对象合并指定路径的txt文件（含子目录）

news 2025/8/29 5:49:25

图(1)

前几天我跟大家分享了在VBA中如何获取指定类型文件的路径的方法，其中最重要的一个思路就是在处理完当前目录的文件后，再调用程序自身来对子目录进行处理，以此来实现对子目录的无限循环，直至所有文件都处理完毕为止。按照此设计思路，今天我来跟大家分享VBA如何合并指定路径的txt文件。

为方便程序调用，我们将合并过程命名为MergeTxtFile，它携带两个参数，一个是filePath表示指定路径，另一个是fileName表示合并后的文件名，因为处理过程是循环进行的，且涉及合并文件和公共变量的清理问题，循环过程只能单独设计为子过程MergeTxt，代码如下：

Public txtFile As String, fileCount As Integer, filesList As String

Sub MergeTxtFile(filePath As String, fileName As String)
'
' 合并指定路径的txt文件（含子目录）
'
' 参数说明：filePath 表示指定路径，fileName 表示合并后的文件名

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.folderExists(filePath) Then
        MsgBox "找不到路径：" & vbCrLf & filePath, vbOKOnly + vbExclamation, "错误"
        Exit Sub
    End If
    
    txtFile = filePath & "\" & fileName
    
    If fso.fileExists(txtFile) Then
        Kill txtFile
        If Err.Number <> 0 Then   ' 错误检查
            Err.Clear   ' 清除错误
            MsgBox "以下文件已打开，请先关闭。" & vbCrLf & txtFile, vbOKOnly + vbExclamation, "错误"
            Exit Sub
        End If
    End If
    
    ' 合并文件
    Call MergeTxt(filePath, fileName)
    Debug.Print filesList & vbCrLf & "执行完毕！总共合并" & fileCount & "个" & "txt文件"

    '清理公共变量
    txtFile = ""
    fileCount = 0
    filesList = ""
End Sub

Sub MergeTxt(filePath As String, fileName As String)
'
' 合并指定路径的txt文件（含子目录）
'
    Dim file As Object
    Dim fileContent As String
    Dim fileNum As Integer
    'Dim fileCount As Integer
    Dim txtFolder As Object
    Dim txtNum As Integer
    
    txtNum = FreeFile                     ' 获取新文件号
    Open txtFile For Append As #txtNum    ' 打开合并文件（追加模式）
    
    '遍历主目录的每个文件
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtFolder = fso.GetFolder(filePath)
    For Each file In txtFolder.Files
        If LCase(fso.GetExtensionName(file.path)) = "txt" Then
        
            ' 获取文件列表
            If file.Name <> fileName Then
                If Len(filesList) = 0 Then
                    filesList = file.path
                Else
                    filesList = filesList & vbCrLf & file.path
                End If
                fileCount = fileCount + 1    ' 计算文件个数

                fileNum = FreeFile                      ' 获取新文件号
                Open file.path For Input As #fileNum    ' 打开当前文件

                ' 将读取内容写入合并文件
                Do While Not EOF(fileNum)               ' 检测文件末尾
                    Line Input #fileNum, fileContent    ' 采用逐行读取的方式
                    Print #txtNum, fileContent
                Loop
                
                Close #fileNum    ' 关闭当前文件
            End If
        End If
    Next file
    
    Close #txtNum    ' 关闭合并文件

    ' 遍历子目录
    For Each subfolder In txtFolder.subFolders
        Call MergeTxt(subfolder.path, fileName)    ' 调用程序自身处理子目录
    Next subfolder

End Sub

以上是通用过程，在使用过程中，我们只需要重新定义变量filePath和fileName的值即可，下面是使用的演示代码：

Sub Demo_MergeTxtFile()
'
' 演示MergeTxtFile函数用法
'
    Dim filePath As String
    Dim fileName As String
    
    filePath = "D:\Users\Hero\Desktop\办公室"
    fileName = "合并TXT.txt"
    
    Call MergeTxtFile(filePath, fileName)
    
End Sub

执行结果如下图：

图(2)