如何修改Excel VBA宏实现指定数量多CSV文件导出？

原有功能回顾 #

• 以A列的"next"为分隔符拆分数据，导出多个CSV直到遇到"stop"
• 文件名规则：对应行S列内容 + "_fileN.csv"（N为序号）
• 为每个CSV复制原工作表顶部表头
• 转义CSV分隔符（如;）
• 支持导出Unicode符号
• 生成标准CSV文件

新增需求 #

保留所有原有功能，新增用户指定导出文件数量的控制，达到指定数量后自动停止导出。

修改后的完整代码 #

Sub export_multiple_CSV()
    Dim MyFileName As String
    Dim CurrentWB As Workbook, TempWB As Workbook
    Dim ws As Worksheet
    Dim lastRow As Long, headerRowCount As Long
    Dim wsCopyRange As Range, headerRange As Range
    
    Dim exportLimit As Variant
    Dim sRow As Long, eRow As Long
    Dim counter As Long: counter = 1
    Dim inSection As Boolean: inSection = False

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set CurrentWB = ActiveWorkbook

    ' 检查目标工作表是否存在
    On Error Resume Next
    Set ws = CurrentWB.Sheets("File")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "找不到名为'File'的工作表！"
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Exit Sub
    End If

    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 假设表头在第1行（可根据实际调整）
    headerRowCount = 1
    Set headerRange = ws.Rows(1)

    ' 获取用户指定的导出数量
    Do
        exportLimit = InputBox("请输入要导出的CSV文件数量（正整数）：", "导出数量设置", "3")
        ' 用户取消输入
        If exportLimit = "" Then
            MsgBox "已取消操作"
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
            Exit Sub
        End If
        ' 验证输入是否为正整数
        If Not IsNumeric(exportLimit) Or exportLimit < 1 Or exportLimit <> Int(exportLimit) Then
            MsgBox "请输入有效的正整数！"
        Else
            Exit Do
        End If
    Loop

    ' 遍历A列拆分数据
    For sRow = 1 To lastRow
        ' 达到导出上限则终止循环
        If counter > exportLimit Then Exit For

        If ws.Cells(sRow, 1).Value = "next" Then
            inSection = True
            eRow = sRow - 1
            ' 处理最后一行的情况
            If sRow = lastRow Then eRow = lastRow
        ElseIf ws.Cells(sRow, 1).Value = "stop" Then
            If inSection Then
                ' 创建临时工作簿
                Set TempWB = Application.Workbooks.Add(1)
                ' 复制表头到临时表
                headerRange.Copy TempWB.Sheets(1).Range("A1")
                ' 复制当前段数据到临时表（表头下一行）
                ws.Rows(eRow).Copy TempWB.Sheets(1).Range("A2")
                
                ' 转义分隔符：将包含分号的单元格用双引号包裹
                Dim cell As Range
                For Each cell In TempWB.Sheets(1).UsedRange
                    If InStr(cell.Value, ";") > 0 Then
                        cell.Value = """" & cell.Value & """"
                    End If
                Next cell

                Application.CutCopyMode = False

                ' 生成文件名
                Dim fName As String
                fName = ws.Cells(eRow, 19).Value & "_file" & counter & ".csv"
                MyFileName = CurrentWB.Path & "\" & fName

                ' 保存为UTF-8编码的CSV（支持Unicode）
                SaveWorkbookAsUTF8 TempWB, MyFileName

                TempWB.Close SaveChanges:=False
                counter = counter + 1
                inSection = False
            End If
        End If
    Next sRow

    ' 提示导出完成
    MsgBox "已完成导出，共生成 " & counter - 1 & " 个CSV文件"

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

' 辅助函数：将工作簿保存为UTF-8编码的CSV
Sub SaveWorkbookAsUTF8(wb As Workbook, filePath As String)
    Dim fs As Object
    Dim ts As Object
    Dim row As Range
    Dim cellValue As String
    Dim lineText As String
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.CreateTextFile(filePath, True, True) ' True=覆盖, True=Unicode(UTF-8 with BOM)

    ' 遍历每行写入
    For Each row In wb.Sheets(1).UsedRange.Rows
        lineText = ""
        For Each cell In row.Cells
            cellValue = cell.Value
            ' 处理双引号：替换为两个双引号（CSV标准转义）
            cellValue = Replace(cellValue, """", """""")
            ' 拼接单元格内容
            If lineText = "" Then
                lineText = cellValue
            Else
                lineText = lineText & ";" & cellValue
            End If
        Next cell
        ts.WriteLine lineText
    Next row

    ts.Close
    Set ts = Nothing
    Set fs = Nothing
End Sub

关键修改说明 #

1. 添加导出数量控制

   • 通过InputBox获取用户输入的导出数量，做合法性验证（必须是正整数）
   • 在循环中加入判断If counter > exportLimit Then Exit For，达到指定数量后立即终止导出

2. 完善表头复制逻辑

   • 明确指定表头范围（示例中为第1行，可根据实际调整headerRowCount）
   • 先复制表头到临时工作簿，再复制数据行到表头下方

3. 实现分隔符转义

   • 遍历临时表的单元格，将包含;的内容用双引号包裹
   • 在UTF-8保存函数中，对单元格内的双引号进行转义（替换为两个双引号，符合CSV标准）

4. 修复Unicode导出问题

   • 替换原SaveAs方法为自定义SaveWorkbookAsUTF8函数，直接写入UTF-8带BOM的文件，确保Unicode符号正确导出

5. 增强错误处理与用户提示

   • 添加工作表不存在的检查提示
   • 处理用户取消输入的情况
   • 导出完成后提示实际生成的文件数量

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