如何将同名列重复数据拆分至多个无重复值的CSV/工作表中

原方案问题说明 #

• 你之前使用的标记重复值公式=IF(COUNTIF($A$2:$A5,A5)>1, "Duplicate","")存在逻辑缺陷：公式仅统计当前行上方范围内的匹配值，一旦数据排序、增删行导致引用范围错位，或是同名记录没有按连续顺序排列，就会出现漏判。
• 你现有VBA代码存在两个问题：一是从上到下遍历行时执行删除操作会导致行号偏移，漏过部分行；二是没有自动循环拆分、新建工作表的逻辑，只能单次操作。

纯Excel公式无法完成跨工作表自动拆分、循环校验、新建存储表的操作，仅能实现重复值标记，要达成你要的「每个文件内名称仅出现一次、按出现轮次分层」的需求，直接使用下方修正后的VBA代码即可，无需提前手动标记Duplicate列。

自动循环拆分VBA代码 #

代码逻辑：

• 从首个工作表开始，自动识别指定的名称列
• 每轮拆分保留当前表内所有名称的首次出现记录，其余重复记录自动移入新建的下一张工作表
• 对新生成的工作表重复执行拆分逻辑，直到新拆分出的工作表无有效重复记录为止
• 从下往上遍历行避免删除操作导致的行号错位，用字典做重复值判断，无漏判

Sub SplitDuplicatesToSeparateSheets()
    Dim currentSht As Worksheet, nextSht As Worksheet
    Dim nameCol As Long, lastRow As Long, i As Long, nextRow As Long
    Dim nameDict As Object, cellVal As Variant
    ' 配置项：修改为Co Name列对应的列号，A列为1，B列为2，以此类推
    nameCol = 4
    ' 关闭界面刷新提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set currentSht = ThisWorkbook.Worksheets(1)
    
    Do
        Set nameDict = CreateObject("Scripting.Dictionary")
        lastRow = currentSht.Cells(currentSht.Rows.Count, nameCol).End(xlUp).Row
        ' 新建工作表存储本轮拆分出的重复行
        Set nextSht = ThisWorkbook.Worksheets.Add(After:=currentSht)
        currentSht.Rows(1).Copy nextSht.Rows(1) ' 复制表头
        nextRow = 2
        ' 从最后一行向上遍历，避免删除行导致的行号错位
        For i = lastRow To 2 Step -1
            cellVal = currentSht.Cells(i, nameCol).Value
            If cellVal <> "" Then
                If nameDict.Exists(cellVal) Then
                    ' 重复行移入新工作表
                    currentSht.Rows(i).Copy nextSht.Rows(nextRow)
                    currentSht.Rows(i).Delete
                    nextRow = nextRow + 1
                Else
                    ' 首次出现的名称保留在当前表
                    nameDict.Add cellVal, ""
                End If
            End If
        Next
        ' 新工作表无有效数据则删除空表，终止循环
        If nextRow = 2 Then
            nextSht.Delete
            Exit Do
        End If
        Set currentSht = nextSht
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "拆分完成，所有工作表内名称无重复值"
End Sub

使用步骤 #

• 打开合并完成的CSV文件，按Alt+F11调出VBA编辑器，右键点击当前工作簿插入模块，将上述代码粘贴到模块中
• 修改代码中nameCol = 4的数值为你实际Co Name列的列号，比如Co Name在D列就保持4，在A列就改为1
• 按F5运行宏，代码会自动完成全部分层拆分，拆分完成后逐个将工作表另存为独立CSV文件即可。

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