求助：用VBA删除整列单元格内的重复条目

一、工作表函数法（快速无代码） #

如果你的Excel是365/2021及以上版本，直接用内置函数组合就能搞定，不用写VBA：
在目标列旁边的单元格输入公式，然后下拉填充：

=TEXTJOIN(" ", TRUE, UNIQUE(TEXTSPLIT(TRIM(A1), " ")))

• TRIM(A1)：去除单元格首尾空格，避免拆分出空字符串
• TEXTSPLIT(..., " ")：按空格把内容拆分成数组
• UNIQUE(...)：去除数组里的重复值
• TEXTJOIN(...)：把去重后的数组重新合并成空格分隔的字符串

适用场景：一次性处理小批量数据，不想碰VBA的情况。
局限：旧版Excel（2019及更早）没有TEXTSPLIT和UNIQUE函数，用不了。

二、VBA方案（兼容全版本，批量高效） #

如果需要自动化批量处理，或者Excel版本较旧，推荐用VBA结合字典（去重效率远高于纯循环），代码如下：

Sub RemoveDuplicatesInCells()
    Dim ws As Worksheet
    Dim targetCol As Range
    Dim cell As Range
    Dim splitArr As Variant
    Dim dict As Object
    Dim i As Integer
    
    ' 自定义目标工作表和列，比如Sheet1的A列，按需修改
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set targetCol = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cell In targetCol
        If cell.Value <> "" Then
            ' 拆分单元格内容（自动处理多个连续空格）
            splitArr = Split(Trim(cell.Value), " ")
            dict.RemoveAll ' 重置字典
            
            ' 遍历拆分后的内容，利用字典自动去重
            For i = LBound(splitArr) To UBound(splitArr)
                If splitArr(i) <> "" Then
                    dict(splitArr(i)) = vbNullString
                End If
            Next i
            
            ' 把去重后的内容写回单元格
            cell.Value = Join(dict.Keys, " ")
        End If
    Next cell
End Sub

纯循环方案（仅适合极小数据量） #

如果不想用字典，也可以用纯循环去重，但数据量大时效率很低，示例代码：

Sub RemoveDuplicatesWithLoop()
    Dim ws As Worksheet
    Dim targetCol As Range
    Dim cell As Range
    Dim splitArr As Variant
    Dim uniqueArr() As String
    Dim isDuplicate As Boolean
    Dim i As Integer, j As Integer, k As Integer
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set targetCol = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    
    For Each cell In targetCol
        If cell.Value <> "" Then
            splitArr = Split(Trim(cell.Value), " ")
            k = -1
            
            For i = LBound(splitArr) To UBound(splitArr)
                If splitArr(i) <> "" Then
                    isDuplicate = False
                    ' 检查当前值是否已在uniqueArr里
                    For j = 0 To k
                        If uniqueArr(j) = splitArr(i) Then
                            isDuplicate = True
                            Exit For
                        End If
                    Next j
                    
                    If Not isDuplicate Then
                        k = k + 1
                        ReDim Preserve uniqueArr(k)
                        uniqueArr(k) = splitArr(i)
                    End If
                End If
            Next i
            
            cell.Value = Join(uniqueArr, " ")
            Erase uniqueArr ' 清空数组
        End If
    Next cell
End Sub

VBA方案选择建议：优先用字典版，处理上万行数据也不会卡；纯循环只适合几行数据的测试场景。

总结选择 #

• 单次小量处理+新版Excel：用工作表函数，最快最省事
• 批量/重复处理+全版本兼容：用VBA字典方案

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