Excel宏技术问询：提取重复姓名数据并生成指定命名工作簿

嘿，我来帮你搞定这个Excel宏的问题！你的需求是把重复姓名对应的A、B列数据拆分到单独的新工作簿，还得用姓名命名存到指定路径对吧？我先梳理下你原来的宏可能踩的坑，再给你一套靠谱的代码，应该能解决你的问题。

先说说你原来的宏可能踩的坑 #

• 没有正确筛选重复出现的姓名（比如只判断了是否重复，但没把所有重复行都捞出来）
• 复制数据时没选中完整的对应行，或者漏了表头
• 保存路径不存在但没做判断，导致保存失败
• 同名工作簿存在时没处理，直接覆盖或者报错
• 没有关闭新建的工作簿，导致Excel后台留一堆进程

给你一套完整的宏代码 #

Sub SplitDuplicateNamesToWorkbooks()
    Dim srcWs As Worksheet
    Dim newWb As Workbook
    Dim lastRow As Long
    Dim nameDict As Object
    Dim i As Long, j As Long
    Dim targetName As String
    Dim savePath As String
    
    ' 设置保存路径，注意末尾要加斜杠
    savePath = "C:\Users\kentan\Desktop\Managed Fund\"
    
    ' 检查保存路径是否存在，不存在则创建
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    ' 源工作表（假设数据在当前激活的工作表）
    Set srcWs = ActiveSheet
    lastRow = srcWs.Cells(srcWs.Rows.Count, "A").End(xlUp).Row
    
    ' 创建字典存储重复姓名及其行号
    Set nameDict = CreateObject("Scripting.Dictionary")
    
    ' 第一步：找出所有重复的姓名
    For i = 2 To lastRow ' 假设第1行是表头
        targetName = Trim(srcWs.Cells(i, "A").Value)
        If targetName <> "" Then
            If nameDict.Exists(targetName) Then
                ' 已经存在，说明是重复项，把当前行号追加进去
                nameDict(targetName) = nameDict(targetName) & "," & i
            Else
                ' 第一次出现，先记录行号
                nameDict(targetName) = CStr(i)
            End If
        End If
    Next i
    
    ' 第二步：遍历字典，只处理重复的姓名（行号数量>1的）
    For Each key In nameDict.keys
        ' 拆分行号字符串为数组
        Dim rowArr As Variant
        rowArr = Split(nameDict(key), ",")
        
        ' 只有当行号数量大于1时，才是重复姓名
        If UBound(rowArr) > 0 Then
            ' 创建新工作簿
            Set newWb = Workbooks.Add
            
            ' 复制表头到新工作簿
            srcWs.Rows(1).Copy newWb.Sheets(1).Rows(1)
            
            ' 复制对应的数据行
            j = 2 ' 新工作簿从第2行开始粘贴
            For Each rowNum In rowArr
                srcWs.Rows(rowNum).Copy newWb.Sheets(1).Rows(j)
                j = j + 1
            Next rowNum
            
            ' 调整列宽
            newWb.Sheets(1).Columns("A:B").AutoFit
            
            ' 保存工作簿，处理同名文件（如果存在就加数字后缀）
            Dim fullFileName As String
            fullFileName = savePath & key & ".xlsx"
            Dim fileNum As Integer
            fileNum = 1
            Do While Dir(fullFileName) <> ""
                fullFileName = savePath & key & "(" & fileNum & ").xlsx"
                fileNum = fileNum + 1
            Loop
            
            ' 保存并关闭新工作簿
            Application.DisplayAlerts = False ' 关闭保存提示
            newWb.SaveAs Filename:=fullFileName, FileFormat:=xlOpenXMLWorkbook
            newWb.Close
            Application.DisplayAlerts = True
        End If
    Next key
    
    ' 提示完成
    MsgBox "重复姓名数据拆分完成！文件已保存到: " & savePath, vbInformation
End Sub

代码说明 #

• 路径处理：自动检查保存路径是否存在，不存在就创建，避免保存失败
• 重复判断：用字典记录每个姓名的所有行号，只处理行号数量>1的（也就是重复的姓名）
• 数据复制：先复制表头，再复制所有对应的数据行，保证结构完整
• 同名文件处理：如果已经有同名工作簿，会自动加(1)(2)这样的后缀，不会覆盖原文件
• 优化体验：关闭保存提示，最后弹出完成提示

使用注意事项 #

• 确保你的源数据第1行是表头（如果不是，把代码里的For i = 2 To lastRow改成For i = 1 To lastRow，同时删除复制表头的代码行）
• 启用宏的时候，要确保Excel的宏安全设置允许运行
• 如果姓名里有特殊字符（比如\ / : * ? " < > |），建议先清理姓名列，不然保存会报错

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