我在D栏中有一些帐户ID,他们的发布日期在B栏中,现在我需要找到重复的帐户ID并从其日期更改颜色...最近的日期黄色和上一个日期red..please帮助。
我试过这些......但是不行!
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
答案 0 :(得分:1)
它差不多好。请注意,dateone
始终等于datetwo
。
您需要再使用一个loop
来查找所有重复项。
从它的日期更改颜色...最近的日期为黄色,前一个日期为红色
这有点复杂,它运作得很好,您必须找到每个id
的最大值并将颜色更改为黄色,之后将所有其他颜色更改为红色。
众多解决方案之一:
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
答案 1 :(得分:0)
您每次都在比较两个相同的值: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