如何在AppendUnique函数中高亮Excel内的重复值单元格

核心思路 #

在原有去重追加逻辑的基础上，新增两步操作：

• 遍历传入的result数组，筛选出已存在于目标Excel区域的重复值
• 通过Excel的Find/FindNext方法定位这些重复值对应的单元格，设置高亮格式

修改后的完整代码示例 #

Function AppendUnique(targetRange As Range, result As Variant) As Boolean
    Dim ws As Worksheet
    Set ws = targetRange.Worksheet
    
    ' 处理非数组输入的情况
    If Not IsArray(result) Then
        result = Array(result)
    End If
    
    Dim dataRange As Range
    ' 获取目标区域中实际有数据的部分（避免遍历整列空单元格）
    If ws.Cells(ws.Rows.Count, targetRange.Column).End(xlUp).Row < targetRange.Row Then
        ' 目标区域为空，直接填充数组
        targetRange.Resize(UBound(result) - LBound(result) + 1).Value = Application.Transpose(result)
        AppendUnique = True
        Exit Function
    Else
        Set dataRange = targetRange.Resize(ws.Cells(ws.Rows.Count, targetRange.Column).End(xlUp).Row - targetRange.Row + 1)
    End If
    
    ' 建立现有数据的字典（用于去重判断）
    Dim existingDict As Object
    Set existingDict = CreateObject("Scripting.Dictionary")
    Dim existingData As Variant
    existingData = dataRange.Value
    
    ' 填充现有数据字典
    Dim i As Long
    For i = 1 To UBound(existingData, 1)
        If Not existingDict.Exists(existingData(i, 1)) Then
            existingDict.Add existingData(i, 1), True
        End If
    Next i
    
    ' 1. 高亮result中的重复值对应的单元格
    Dim v As Variant, findCell As Range, firstAddr As String
    For Each v In result
        If existingDict.Exists(v) Then
            ' 查找所有匹配的单元格
            Set findCell = dataRange.Find(What:=v, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            If Not findCell Is Nothing Then
                firstAddr = findCell.Address
                Do
                    ' 设置高亮（这里用黄色背景，可根据需求调整）
                    findCell.Interior.Color = RGB(255, 255, 0)
                    Set findCell = dataRange.FindNext(findCell)
                Loop While Not findCell Is Nothing And findCell.Address <> firstAddr
            End If
        End If
    Next v
    
    ' 2. 追加新增的唯一值
    Dim newValues As Collection
    Set newValues = New Collection
    For Each v In result
        If Not existingDict.Exists(v) Then
            newValues.Add v
            existingDict.Add v, True ' 加入字典避免重复追加
        End If
    Next v
    
    ' 写入新增值到目标区域下方
    If newValues.Count > 0 Then
        Dim outputArr() As Variant
        ReDim outputArr(1 To newValues.Count, 1 To 1)
        For i = 1 To newValues.Count
            outputArr(i, 1) = newValues(i)
        Next i
        ws.Cells(dataRange.Row + dataRange.Rows.Count, targetRange.Column).Resize(newValues.Count).Value = outputArr
    End If
    
    AppendUnique = True
End Function

关键细节说明 #

• 定位重复值：使用Find和FindNext组合遍历所有匹配单元格，确保不会遗漏同一值的多个出现位置
• 高亮格式：示例中用RGB(255,255,0)设置黄色背景，可替换为ColorIndex（如findCell.Interior.ColorIndex = 6）或其他颜色值
• 数据范围优化：先获取目标区域的实际数据范围，避免遍历大量空单元格，提升效率
• 数组处理：兼容非数组类型的输入（如单个值传入），确保函数鲁棒性

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