Excel VBA需求：遍历5万+行数据，按A列ID分组复制导出至新工作簿

先明确你的核心需求：从Backup工作表（A:N列，5万+行）中，按**ID列（A列）**分组，每一组相同ID的行（包含表头）单独导出到一个新工作簿，实现数据合并的反向拆分。

现有代码的问题分析 #

你的当前代码存在几个关键问题，导致无法实现需求：

• Do循环内直接写了Exit Do，只会执行一次，完全没有遍历所有行
• 代码逻辑是插入总计行，和“拆分数据到新工作簿”的需求完全偏离
• 变量声明不规范：比如Dim wsBData, wsBackup As Worksheet中，只有wsBackup是Worksheet类型，其余变量默认是Variant，容易引发类型错误
• 没有处理“创建新工作簿并粘贴数据”的核心逻辑

优化后的VBA代码 #

下面是适配你需求的完整代码，包含注释说明关键逻辑：

Sub SplitDataByID()
    ' 声明变量，严格指定类型
    Dim wbSource As Workbook
    Dim wsBackupData As Worksheet, wsBackup As Worksheet
    Dim lastRow As Long, startRow As Long, currentRow As Long
    Dim currentID As Variant
    Dim wbNew As Workbook
    Dim savePath As String
    
    ' 初始化源工作簿和工作表
    Set wbSource = ActiveWorkbook
    Set wsBackupData = wbSource.Sheets("BackupData")
    Set wsBackup = wbSource.Sheets("Backup")
    
    ' 第一步：将BackupData的值复制到Backup（保留你原有的逻辑）
    wsBackupData.UsedRange.Copy
    wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False ' 清除复制状态
    
    ' 获取Backup表的最后一行（A列非空行）
    lastRow = wsBackup.Range("A" & wsBackup.Rows.Count).End(xlUp).Row
    If lastRow < 2 Then
        MsgBox "Backup表中没有数据！", vbExclamation
        Exit Sub
    End If
    
    ' 设置保存路径（可自行修改，这里用源工作簿所在文件夹）
    savePath = wbSource.Path & "\"
    
    ' 初始化分组起始行（第2行是数据行，第1行是表头）
    startRow = 2
    currentID = wsBackup.Range("A" & startRow).Value
    
    ' 遍历所有数据行
    For currentRow = startRow + 1 To lastRow
        ' 当ID变化时，处理当前分组
        If wsBackup.Range("A" & currentRow).Value <> currentID Then
            ' 创建新工作簿
            Set wbNew = Workbooks.Add(xlWBATWorksheet) ' 只创建一个工作表
            
            ' 复制表头到新工作簿
            wsBackup.Rows(1).Copy wbNew.Sheets(1).Range("A1")
            
            ' 复制当前ID分组的数据到新工作簿（从startRow到currentRow-1）
            wsBackup.Range("A" & startRow & ":N" & currentRow - 1).Copy _
                wbNew.Sheets(1).Range("A2")
            
            ' 保存新工作簿（文件名用当前ID命名，避免重复）
            On Error Resume Next ' 处理文件名重复的情况
            wbNew.SaveAs Filename:=savePath & "ID_" & currentID & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            On Error GoTo 0
            
            ' 关闭新工作簿
            wbNew.Close SaveChanges:=False
            
            ' 更新起始行和当前ID
            startRow = currentRow
            currentID = wsBackup.Range("A" & startRow).Value
        End If
    Next currentRow
    
    ' 处理最后一组数据
    If startRow <= lastRow Then
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
        wsBackup.Rows(1).Copy wbNew.Sheets(1).Range("A1")
        wsBackup.Range("A" & startRow & ":N" & lastRow).Copy _
            wbNew.Sheets(1).Range("A2")
        On Error Resume Next
        wbNew.SaveAs Filename:=savePath & "ID_" & currentID & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        On Error GoTo 0
        wbNew.Close SaveChanges:=False
    End If
    
    MsgBox "数据拆分完成！所有文件已保存到：" & savePath, vbInformation
End Sub

代码关键说明 #

• 变量类型规范：所有变量都明确指定类型，避免Variant类型的潜在问题
• 高效遍历：使用For循环遍历行，比Do循环更直观，适合这种连续数据的分组场景
• 分组逻辑：通过记录currentID和startRow，准确识别每个ID的起始和结束行
• 文件保存：自动以ID命名文件，保存到源工作簿所在文件夹，同时处理文件名重复的异常
• 最后一组处理：单独处理循环结束后剩下的最后一组数据，避免遗漏

注意事项 #

• 确保Backup工作表的A列（ID列）是连续分组的（即相同ID的行是连续的），如果ID是乱序的，需要先对A列排序后再执行代码
• 5万+行数据执行时，可能需要几分钟时间，请耐心等待，不要中断Excel进程
• 可根据需要修改savePath变量，指定自定义的保存文件夹

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