请求Excel/VBA脚本：合并不同文件夹同名CSV至新文件夹同名文件

需求概述 #

• 3个工作室的播音记录为日期命名的CSV文件，分别存储在各自专属文件夹中
• 需要将同名CSV（同一日期）合并为单个文件，按时间排序后保存到指定文件夹，供RadioBoss生成单份PDF报告
• 支持批量处理所有CSV文件，兼容部分工作室无对应日期文件的场景
• 替换原有仅支持单日期、双文件夹的手动录制宏

改进后的VBA代码 #

Sub BatchCombineCSV()
    ' 定义工作室文件夹路径，可根据实际情况修改
    Dim folderPaths As Variant
    folderPaths = Array("C:\CSV Testing\1WHK", "C:\CSV Testing\2SWK", "C:\CSV Testing\3WHK")
    ' 定义合并后文件的输出文件夹路径
    Dim outputFolder As String
    outputFolder = "C:\CSV Testing\CombinedxCSV"
    
    ' 如果输出文件夹不存在，自动创建
    If Dir(outputFolder, vbDirectory) = "" Then
        MkDir outputFolder
    End If
    
    ' 收集所有唯一的日期文件名（避免重复处理）
    Dim allDates As Collection
    Set allDates = New Collection
    
    Dim folderPath As Variant
    Dim fileName As String
    ' 遍历所有工作室文件夹，提取CSV文件名
    For Each folderPath In folderPaths
        fileName = Dir(folderPath & "\*.csv")
        Do While fileName <> ""
            On Error Resume Next
            allDates.Add fileName, Key:=fileName ' 利用Key属性自动去重
            On Error GoTo 0
            fileName = Dir
        Loop
    Next folderPath
    
    ' 遍历每个日期文件，执行合并操作
    Dim dateFile As Variant
    For Each dateFile In allDates
        Dim combinedData As Variant
        ReDim combinedData(0 To 0) ' 初始化存储合并数据的数组
        
        ' 遍历每个工作室文件夹，读取对应日期的CSV
        For Each folderPath In folderPaths
            Dim filePath As String
            filePath = folderPath & "\" & dateFile
            
            ' 检查当前工作室是否存在该日期的CSV文件
            If Dir(filePath) <> "" Then
                Dim tempWB As Workbook
                ' 按照RadioBoss的CSV格式规则打开文件（分隔符为$）
                Set tempWB = Workbooks.OpenText(Filename:=filePath, _
                    Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, _
                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
                    Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
                    Other:=True, OtherChar:="$", FieldInfo:=Array(1, 1), _
                    TrailingMinusNumbers:=True)
                
                ' 获取当前文件的有效数据行数
                Dim lastRow As Long
                lastRow = tempWB.Sheets(1).Cells(tempWB.Sheets(1).Rows.Count, "A").End(xlUp).Row
                
                If lastRow >= 1 Then
                    Dim tempData As Variant
                    tempData = tempWB.Sheets(1).Range("A1:A" & lastRow).Value
                    
                    ' 将当前文件的数据合并到总数据数组中
                    Dim i As Long
                    For i = 1 To UBound(tempData)
                        ReDim Preserve combinedData(0 To UBound(combinedData) + 1)
                        combinedData(UBound(combinedData)) = tempData(i, 1)
                    Next i
                End If
                
                ' 关闭临时工作簿，不保存修改
                tempWB.Close SaveChanges:=False
            End If
        Next folderPath
        
        ' 如果合并后有数据，生成新的CSV文件
        If UBound(combinedData) > 0 Then
            Dim newWB As Workbook
            Set newWB = Workbooks.Add(xlWBATWorksheet) ' 创建仅含一个工作表的工作簿
            
            ' 将合并数据写入新工作表
            newWB.Sheets(1).Range("A1:A" & UBound(combinedData)).Value = Application.Transpose(combinedData)
            
            ' 按A列的时间信息排序数据
            With newWB.Sheets(1).Sort
                .SortFields.Clear
                .SortFields.Add Key:=newWB.Sheets(1).Range("A:A"), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange newWB.Sheets(1).Range("A1:A" & UBound(combinedData))
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            ' 保存为UTF-8格式的CSV到输出文件夹
            newWB.SaveAs Filename:=outputFolder & "\" & dateFile, _
                FileFormat:=xlCSVUTF8, CreateBackup:=False
            
            ' 关闭新工作簿
            newWB.Close SaveChanges:=False
        End If
    Next dateFile
    
    MsgBox "批量合并完成！", vbInformation
End Sub

代码关键说明 #

1. 路径配置：开头的folderPaths数组和outputFolder变量可直接修改为实际文件夹路径
2. 自动收集日期：遍历所有工作室文件夹，自动收集所有唯一的CSV文件名（日期），避免遗漏任何日期
3. 兼容无文件场景：读取前检查文件是否存在，不存在则跳过对应工作室的文件
4. 高效数据处理：用数组存储合并数据，比手动复制粘贴更高效，适合大量文件场景
5. 自动排序：合并完成后自动按A列时间排序，符合RadioBoss的读取要求
6. 自动创建文件夹：如果输出文件夹不存在，脚本会自动创建

内容的提问来源于stack exchange，提问作者K7-Tech