求助：使用VBA提取预订数据并生成对应命名的独立文件

核心逻辑 #

• 以预订编号作为每个条目的识别标记（假设编号在A列，且每个新预订的编号会在A列新行出现）
• 遍历数据区域，定位每个预订的起始行与结束行
• 将单个预订的完整数据复制到新工作簿，以对应编号命名并保存

完整VBA代码 #

Sub SplitBookingsToFiles()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim lastRow As Long, startRow As Long, endRow As Long
    Dim bookingID As String
    Dim savePath As String
    
    ' 设置源工作表（可根据实际修改）
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    ' 保存路径默认用原文件所在文件夹，可自定义
    savePath = ThisWorkbook.Path & "\"
    
    ' 获取数据最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    startRow = 2 ' 假设第1行是表头，数据从第2行开始
    
    Do While startRow <= lastRow
        ' 获取当前预订编号
        bookingID = wsSource.Cells(startRow, "A").Value
        ' 找到下一个预订的起始行（即当前预订的结束行+1）
        endRow = wsSource.Cells(startRow + 1, "A").End(xlDown).Row
        ' 处理最后一个预订的边界情况
        If endRow > lastRow Then endRow = lastRow
        
        ' 创建新工作簿
        Set wbNew = Workbooks.Add
        ' 复制当前预订的表头+数据到新工作簿
        wsSource.Rows("1:" & endRow).Copy Destination:=wbNew.Worksheets(1).Rows(1)
        ' 删除新工作簿中多余的工作表（默认新建会有3个）
        Application.DisplayAlerts = False
        Do While wbNew.Worksheets.Count > 1
            wbNew.Worksheets(2).Delete
        Loop
        Application.DisplayAlerts = True
        
        ' 保存新文件
        On Error Resume Next ' 处理重名情况
        wbNew.SaveAs Filename:=savePath & bookingID & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        On Error GoTo 0
        
        ' 关闭新工作簿
        wbNew.Close SaveChanges:=False
        
        ' 更新起始行到下一个预订
        startRow = endRow + 1
    Loop
    
    MsgBox "拆分完成！"
End Sub

关键说明 #

• 调整识别规则：如果预订编号不在A列，或者识别标记不是编号，可修改代码中Cells(startRow, "A")的列号，或新增判断条件（比如通过特定关键字识别预订起始行）
• 表头处理：代码默认复制第1行作为表头，若你的表头行数不同，修改Rows("1:" & endRow)中的"1"为实际表头行数
• 保存格式：如果需要保存为其他格式（如CSV），修改FileFormat参数为xlCSV即可
• 错误处理：代码中加入了重名文件的容错，若需要覆盖重名文件，可删除On Error Resume Next相关行

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