VBA实现数据拆分达工作簿上限时自动新建保存并续跑程序

核心改造点 #

• 新增单工作簿工作表数量阈值，默认设置为1000（预留冗余避免触碰不同Excel版本的sheet数上限边界报错）
• 新增工作簿自动轮转逻辑：当前工作簿拆分sheet数达到阈值时，自动按record1、record2的命名规则保存到源文件同目录，随即新建空白工作簿继续拆分
• 优化运行效率：全程关闭屏幕刷新、系统弹窗，提前计算源数据边界，减少重复对象调用
• 完全保留原有空行识别拆分逻辑，兼容单条记录行数不固定、部分单元格无有效数据的特性
• 新增收尾保存逻辑：所有数据拆分完成后自动保存最后一个未达阈值的工作簿，避免数据遗漏

使用说明 #

• 运行代码前务必备份原始数据，避免误操作导致数据损失
• 可根据自身Excel版本调整单工作簿最大sheet数阈值，建议最高不超过1000
• 所有拆分生成的文件会统一保存在原始数据文件所在的文件夹下

改造后完整代码 #

Private Sub excelsplit()
    ' 配置项：单工作簿最大存放拆分记录sheet数，可按需调整
    Const MAX_SHEET_PER_WB As Long = 1000
    Dim sourceSht As Worksheet
    Dim currWb As Workbook
    Dim l_str As Long, l_row As Long, lastRow As Long
    Dim wbIndex As Long, currSheetCount As Long
    Dim savePath As String
    
    ' 初始化环境，提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 绑定源数据工作表，获取基础参数
    Set sourceSht = ThisWorkbook.Sheets(1)
    savePath = ThisWorkbook.Path & "\"
    lastRow = sourceSht.Range("A1000000").End(xlUp).Row
    
    ' 清理初始工作簿内除源数据外的其他sheet
    Do Until ThisWorkbook.Sheets.Count = 1
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Delete
    Loop
    Set currWb = ThisWorkbook
    wbIndex = 1
    currSheetCount = 0
    
    ' 核心拆分循环
    l_str = 2
    l_row = 2
    Do While l_row <= lastRow + 1
        ' 识别A-L列全空的分隔行
        If sourceSht.Range("A" & l_row).Value = "" And _
            sourceSht.Range("B" & l_row).Value = "" And _
            sourceSht.Range("C" & l_row).Value = "" And _
            sourceSht.Range("D" & l_row).Value = "" And _
            sourceSht.Range("E" & l_row).Value = "" And _
            sourceSht.Range("F" & l_row).Value = "" And _
            sourceSht.Range("G" & l_row).Value = "" And _
            sourceSht.Range("H" & l_row).Value = "" And _
            sourceSht.Range("I" & l_row).Value = "" And _
            sourceSht.Range("J" & l_row).Value = "" And _
            sourceSht.Range("K" & l_row).Value = "" And _
            sourceSht.Range("L" & l_row).Value = "" Then
            
            ' 检查当前工作簿是否存满，存满则保存并新建工作簿
            If currSheetCount >= MAX_SHEET_PER_WB Then
                currWb.SaveAs Filename:=savePath & "record" & wbIndex & ".xlsx", FileFormat:=xlOpenXMLWorkbook
                currWb.Close
                wbIndex = wbIndex + 1
                Set currWb = Workbooks.Add
                ' 清理新工作簿默认生成的空白sheet
                Do Until currWb.Sheets.Count = 1
                    currWb.Sheets(currWb.Sheets.Count).Delete
                Loop
                currSheetCount = 0
            End If
            
            ' 新建sheet写入当前条记录
            currWb.Sheets.Add after:=currWb.Sheets(currWb.Sheets.Count)
            currWb.Sheets(currWb.Sheets.Count).Range("A2:L" & l_row - l_str + 1).Value = _
                sourceSht.Range("A" & l_str & ":L" & l_row - 1).Value
            currSheetCount = currSheetCount + 1
            l_str = l_row + 1
        End If
        l_row = l_row + 1
    Loop
    
    ' 保存最后一个未达阈值的工作簿
    currWb.SaveAs Filename:=savePath & "record" & wbIndex & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分完成，共生成" & wbIndex & "个拆分文件", vbInformation
End Sub

逻辑修正说明 #

原代码存在一处边界bug：写入拆分数据时范围包含了作为分隔符的空行，改造后修正了复制范围，仅取空行上方的有效记录行写入新sheet，和预期拆分效果一致。

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