基于B列删除重复行并保留唯一记录的VBA技术问询

先聊聊你现有代码里的几个关键问题，这些问题会导致你没法实现“保留唯一记录”的需求：

• 复制范围拼接错误：Range("A2:AA1000" & lCopyLastRow) 会把范围拼成类似AA1000100的无效格式，应该直接把行号拼在列名后面。
• 去重逻辑有误：用CountIf>1直接删行的话，会把所有重复项（包括第一次出现的那条）都删掉——因为只要B列里该值出现次数大于1，当前行就会被删除，最后你会丢失所有重复的记录，而不是保留一条。
• 工作表引用不严谨：删除行时用Rows(i).Delete没指定工作表，要是操作中不小心激活了其他工作表，就会出问题，得明确指定sh.Rows(i).Delete。

下面是调整后的完整代码，已经修复了这些问题，能正确保留B列每个唯一值的第一条记录：

Sub RemoveDuplicatesByColumnB()
    Dim fName As String, fPath As String
    Dim wb As Workbook, sh As Worksheet
    Dim i As Long, lCopyLastRow As Long, lDestLastRow As Long
    Dim seenValues As New Collection ' 用来记录已经出现过的B列值
    
    Set sh = ActiveSheet
    fPath = ThisWorkbook.Path & "\"
    fName = Dir(fPath & "*.xls*")
    
    ' 遍历文件夹下的所有Excel文件并复制数据
    Do
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            With wb.Sheets(1)
                lCopyLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
                ' 修正复制范围的写法
                .Range("A2:AA" & lCopyLastRow).Copy sh.Range("B" & sh.Cells(sh.Rows.Count, "A").End(xlUp).Offset(1).Row)
            End With
            
            ' 填写Source列
            sh.Range("A1") = "Source"
            With sh
                lDestLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
                .Range(.Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1), .Cells(lDestLastRow, 1)) = fName
            End With
            
            wb.Close SaveChanges:=False ' 关闭文件不保存，避免误修改源文件
        End If
        Set wb = Nothing
        fName = Dir
    Loop Until fName = ""
    
    ' 从下往上遍历，基于B列去重，保留第一条出现的记录
    For i = sh.Cells(sh.Rows.Count, "B").End(xlUp).Row To 2 Step -1
        On Error Resume Next ' 忽略重复添加到集合的错误
        seenValues.Add sh.Cells(i, 2).Value, Key:=CStr(sh.Cells(i, 2).Value)
        On Error GoTo 0 ' 恢复正常错误处理
        
        ' 如果添加失败（说明该值已经存在），就删除当前行
        If Err.Number <> 0 Then
            sh.Rows(i).Delete
            Err.Clear
        End If
    Next i
End Sub

关键调整说明： #

1. 复制范围修正：把"A2:AA1000" & lCopyLastRow改成"A2:AA" & lCopyLastRow，确保复制的是从A2到AA列最后一行的有效数据。
2. 用Collection记录已出现值：利用Collection的Key唯一性判断B列值是否已出现，第一次出现的会被存入集合，后续出现的直接删除行，保证每个唯一值只保留第一条记录。
3. 严谨的工作表引用：所有单元格操作都明确指定了工作表对象sh，避免跨工作表操作的错误。
4. 关闭文件不保存：添加SaveChanges:=False，防止误修改源文件。

如果你追求更简洁的写法，也可以在数据复制完成后直接调用Excel内置的去重功能，效率更高：

' 替换原有的遍历删除代码，直接用内置去重
sh.Range("A1:AA" & sh.Cells(sh.Rows.Count, "B").End(xlUp).Row).RemoveDuplicates Columns:=2, Header:=xlYes

这个方法会自动保留B列每个唯一值的第一条记录，适合数据量较大的场景。

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