Excel宏创建新工作簿后停止运行，重复姓名数据导出需求遇阻

看起来你遇到的问题大概率是宏在创建新工作簿后没有正确切换回原工作簿，或者循环逻辑里的重复判断、数据复制环节出了问题。我帮你整理了一套修正后的宏代码，同时会解释关键部分，帮你理解为什么之前的代码会卡住。

首先明确需求核心：

• 遍历A列姓名，找出**重复出现（次数≥2）**的姓名
• 对每个重复姓名，把所有对应的A、B行数据复制到以该姓名命名的新工作簿，保存到指定路径C:\Users\kentan\Desktop\Managed Fund\

修正后的完整宏代码 #

Sub ExportDuplicateNamesToWorkbooks()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim lastRow As Long
    Dim nameRange As Range
    Dim cell As Range
    Dim uniqueNames As Collection
    Dim name As Variant
    Dim exportPath As String
    
    ' 设置导出路径，确保末尾有斜杠
    exportPath = "C:\Users\kentan\Desktop\Managed Fund\"
    
    ' 检查路径是否存在，不存在则自动创建
    If Dir(exportPath, vbDirectory) = "" Then
        MkDir exportPath
    End If
    
    ' 锁定源工作表（可替换为Sheets("你的工作表名")指定具体表）
    Set wsSource = ActiveSheet
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    Set nameRange = wsSource.Range("A2:A" & lastRow) ' 假设A1是表头，数据从A2开始
    
    ' 收集所有重复姓名（自动去重）
    Set uniqueNames = New Collection
    
    On Error Resume Next ' 忽略重复添加的报错
    For Each cell In nameRange
        ' 只收集出现次数≥2的姓名，且每个姓名仅存一次
        If WorksheetFunction.CountIf(nameRange, cell.Value) >= 2 Then
            uniqueNames.Add cell.Value, Key:=CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0 ' 恢复正常错误捕获
    
    ' 遍历每个重复姓名，创建工作簿并复制数据
    For Each name In uniqueNames
        ' 创建新工作簿
        Set wbNew = Workbooks.Add
        
        ' 复制表头到新工作簿
        wsSource.Range("A1:B1").Copy Destination:=wbNew.Sheets(1).Range("A1")
        
        ' 筛选源表中当前姓名的数据并复制
        wsSource.Range("A1:B" & lastRow).AutoFilter Field:=1, Criteria1:=name
        wsSource.Range("A2:B" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbNew.Sheets(1).Range("A2")
        
        ' 关闭筛选
        wsSource.AutoFilterMode = False
        
        ' 保存并关闭新工作簿
        wbNew.SaveAs Filename:=exportPath & name & ".xlsx"
        wbNew.Close SaveChanges:=False
        
        ' 释放对象，避免内存泄漏
        Set wbNew = Nothing
    Next name
    
    MsgBox "导出完成！所有重复姓名的数据已保存到指定路径。"
End Sub

你的宏停止运行的常见原因&代码优化点 #

1. 未锁定源工作表：如果创建新工作簿后没有明确指定操作对象，宏会默认把后续逻辑指向新工作簿，导致原表遍历中断。代码里提前用Set wsSource = ActiveSheet锁定源表，所有操作都明确绑定wsSource，避免切换错误。
2. 重复姓名判断逻辑混乱：没做去重的话，同一个姓名会重复创建工作簿，或者漏处理重复项。这里用Collection的Key属性确保每个重复姓名仅处理一次。
3. 路径不存在报错：如果指定的保存路径没创建，宏会在保存时直接崩溃。代码添加了路径检查，自动创建不存在的文件夹。
4. 数据复制不精准：用AutoFilter+SpecialCells(xlCellTypeVisible)确保只复制对应姓名的所有行，避免复制无关数据。

使用注意事项 #

• 若你的数据没有表头，需要删除复制表头的代码行，并把nameRange的起始行改成A1。
• 如果需要导出所有姓名（包括只出现一次的），把CountIf(nameRange, cell.Value) >= 2改成>=1即可。
• 运行宏前建议先保存源工作簿，避免意外导致数据丢失。

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