VBA去重功能失效：B列重复项删除需求未实现排查

嘿，我帮你找到了代码里的核心问题，咱们一步步来搞定它：

1. 为什么去重逻辑几乎没生效？ #

你代码最后一行的RemoveDuplicates方法参数写错了！

Information1.RemoveDuplicates Columns:=3, Header:=xlYes

这里的Columns:=3是告诉Excel基于你选中范围的第三列来判断重复，但你选中的Information1是B1:D[最后行]这个范围，第三列是D列（PROGRAM_TYPE_LETTER），而你实际要检查的是B列的重复值。这就是为什么本该有50个不同值，却只识别出2个重复项——因为D列的重复值太少了！

要基于B列去重，你需要把参数改成Columns:=1（B列是这个范围的第一列）。

2. 修正后的完整代码 #

我还帮你优化了代码的可读性，用变量代替重复的工作表引用，避免频繁的Select操作（这是VBA的最佳实践哦）：

Sub Expa()
    Dim wsBlank As Worksheet
    Set wsBlank = ThisWorkbook.Worksheets("STUDYBOARD_ID Blank")
    Dim wsBase As Worksheet
    Set wsBase = ThisWorkbook.Worksheets("Base")
    
    '填充唯一列表数据
    For i = 2 To 18288
        If IsEmpty(wsBase.Cells(i, 8)) Then
            wsBlank.Cells(i, 2) = wsBase.Cells(i, 2)
            wsBlank.Cells(i, 3) = wsBase.Cells(i, 9)
            wsBlank.Cells(i, 4) = wsBase.Cells(i, 10)
        End If
    Next i
    
    '填充完整列表数据
    For i = 2 To 18288
        If IsEmpty(wsBase.Cells(i, 8)) Then
            wsBlank.Cells(i, 7) = wsBase.Cells(i, 2)
            wsBlank.Cells(i, 8) = wsBase.Cells(i, 9)
            wsBlank.Cells(i, 9) = wsBase.Cells(i, 10)
        End If
    Next i
    
    '设置唯一列表表头
    With wsBlank.Cells(1, 2)
        .Font.Bold = True
        .Value = "Unik liste"
    End With
    wsBlank.Cells(2, 2) = "PROGRAM_CODE"
    wsBlank.Cells(2, 3) = "FACULTY_ID"
    wsBlank.Cells(2, 4) = "PROGRAM_TYPE_LETTER"
    
    '设置完整列表表头
    With wsBlank.Cells(1, 6)
        .Font.Bold = True
        .Value = "Fuld liste"
    End With
    wsBlank.Cells(2, 7) = "PROGRAM_CODE"
    wsBlank.Cells(2, 8) = "FACULTY_ID"
    wsBlank.Cells(2, 9) = "PROGRAM_TYPE_LETTER"
    
    '排序唯一列表
    With wsBlank.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsBlank.Range("B2:B18288"), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .SetRange wsBlank.Range("B2:E18288")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    wsBlank.Columns("A:F").AutoFit
    
    '排序完整列表
    With wsBlank.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsBlank.Range("G2:G18288"), _
                        SortOn:=xlSortOnValues, _
                        Order:=xlAscending, _
                        DataOption:=xlSortNormal
        .SetRange wsBlank.Range("G2:J18288")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    wsBlank.Columns("F:J").AutoFit
    
    '修正后的去重逻辑：基于B列（范围的第1列）去重
    Dim Information1 As Range
    Dim lastRow As Long
    lastRow = wsBlank.Range("B" & wsBlank.Rows.Count).End(xlUp).Row
    Set Information1 = wsBlank.Range("B1:D" & lastRow)
    'Columns:=1 对应范围中的第一列（即B列）
    Information1.RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

3. 如果你需要的是「清空重复行的B/C/D单元格而非删除整行」 #

你描述里提到“若存在重复则删除B13、B14、B15单元格”，如果这是指清空重复行的B、C、D列内容而不是删除整行，那可以用字典来跟踪已出现的值，从下往上遍历避免索引混乱：

'替换上述代码中最后一段去重逻辑，改用以下代码
Dim lastRow As Long
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

lastRow = wsBlank.Range("B" & wsBlank.Rows.Count).End(xlUp).Row

'从下往上遍历，防止清空单元格后行索引错位
For i = lastRow To 3 Step -1 '从第3行开始，跳过表头行
    Dim bValue As Variant
    bValue = wsBlank.Cells(i, 2).Value
    If Not IsEmpty(bValue) Then
        If dict.Exists(bValue) Then
            '清空当前行的B、C、D单元格
            wsBlank.Range("B" & i & ":D" & i).ClearContents
        Else
            '记录第一次出现的值
            dict.Add bValue, i
        End If
    End If
Next i

这样修改后，就能正确识别B列的重复项，得到你预期的约50个不同值啦！

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