查找重复并更改其颜色

我在D列中有一些帐户ID，他们在B列的发行date，现在我需要find重复的帐户ID并从它的date改变它们的颜色。对于最近的date黄色和以前的date红色..请帮助..

我试试这些..但是不行！

Sub Duplicates() Dim Rng As Range Dim cel As Range i As Long Dim dateone As Date, datetwo As Date 'Test for duplicates in a single column 'Duplicates will be highlighted in red Set Rng = Range(Range("D1"), Range("D" & Rows.Count).End(xlUp)) For Each cel In Rng If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then dateone = DateValue(cel.Offset(0, -2)) datetwo = DateValue(cel.Offset(0, -2)) If dateone < datetwo Then cel.Interior.ColorIndex = 3 Else cel.Interior.ColorIndex = 5 End If End If Next cel i = i + 1 End Sub 

Answer 1

它几乎好。 请注意， dateone总是等于datetwo 。 您需要使用一个loop来查找所有重复。

从date改变他们的颜色..黄色的最近date和红色的前一个date

这有点复杂，它工作得很好，你必须find每个id的最大值，并将颜色更改为黄色，然后将所有其他更改为红色。

众多解决scheme之一：

 Sub Duplicates() Dim Rng As Range Dim cel As Range, cel2 As Range, i As Long Dim datemax As Date 'Test for duplicates in a single column 'Duplicates will be highlighted in red Set Rng = Range(Range("D1"), Range("D" & Rows.Count).End(xlUp)) 'change color all id to white Rng.Interior.Color = vbWhite For Each cel In Rng If WorksheetFunction.CountIf(Rng, cel.Value) > 1 And cel.Interior.Color = vbWhite Then datemax = DateValue(cel.Offset(0, -2)) 'find the maximum date For Each cel2 In Rng If cel2.Value = cel.Value And datemax < DateValue(cel2.Offset(0, -2)) Then datemax = DateValue(cel2.Offset(0, -2)) End If Next cel2 'coloring cells For Each cel2 In Rng If cel2.Value = cel.Value Then If datemax = DateValue(cel2.Offset(0, -2)) Then cel2.Interior.Color = vbYellow Else cel2.Interior.Color = vbRed End If End If Next cel2 End If Next cel End Sub 

Answer 2

您每次比较两个相同的值： dateone = DateValue(cel.Offset(0, -2))和datetwo = DateValue(cel.Offset(0, -2))

尝试这个 ：

 Sub Duplicates() Dim LastRow As Integer, _ i As Integer, _ k As Integer, _ DateOne As Date, _ DateTwo As Date With ActiveSheet LastRow = .Range("D" & .Rows.Count).End(xlUp) For i = 1 To LastRow - 1 For k = i + 1 To LastRow 'Test for duplicates in a single column If .Cells(i, 4) <> .Cells(k, 4) Then Else DateOne = DateValue(.Cells(i, 2)) DateTwo = DateValue(.Cells(k, 2)) If DateOne < DateTwo Then .Cells(i, 4).Interior.ColorIndex = 3 .Cells(k, 4).Interior.ColorIndex = 5 Else .Cells(i, 4).Interior.ColorIndex = 5 .Cells(k, 4).Interior.ColorIndex = 3 End If End If Next k Next i End With End Sub