Question

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

Answer 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

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

查找重复并更改其颜色

2 个答案: