查找重复并更改其颜色

时间:2015-06-08 06:36:07

标签: excel vba excel-vba

我在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

2 个答案:

答案 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