Question

如何在同一日期或第二天的时间范围内突出显示重复的部件号。

 1qwerty      2017-02-28
 2qwerty      2017-02-26
 3qwerty      2017-02-21
 4qwerty      2017-02-21
 4qwerty      2017-02-21
 5qwerty      2017-02-21
 2qwerty      2017-02-20
 3qwerty      2017-02-20
 5qwerty      2017-02-20
 6qwerty      2017-02-19

因此，在这种情况下，第5，第8和第9行将突出显示，因为它们是在搜索的部件号的同一天或第二天。我需要创建一个循环来为每一行执行此操作，可能是100行。

这里有一些更多的数据，我把它放在突出显示的位置以及它没有工作的位置应该是高亮的，谢谢

 2017-02-27 1qwerty   Highlighted
 2017-02-27 2qwerty 
 2017-02-27 1qwerty 
 2017-02-27 3qwerty 
 2017-02-27 4qwerty 
 2017-02-27 5qwerty 
 2017-02-27 6qwerty 
 2017-02-24 5qwerty 
 2017-02-23 14qwerty    
 2017-02-23 15qwerty    
 2017-02-23 16qwerty    
 2017-02-23 14qwerty   Highlighted
 2017-02-22 17qwerty    
 2017-02-22 1qwerty 
 2017-02-21 14qwerty    
 2017-02-21 19qwerty    
 2017-02-20 6qwerty 
 2017-02-20 20qwerty    
 2017-02-20 21qwerty    
 2017-02-20 19qwerty   Highlighted
 2017-02-20 1qwerty 
 2017-02-17 5qwerty 
 2017-02-17 14qwerty    
 2017-02-17 1qwerty 
 2017-02-17 22qwerty    
 2017-02-17 23qwerty    
 2017-02-17 1qwerty   Should be Highlighted
 2017-02-17 19qwerty    
 2017-02-17 1qwerty   Should be Highlighted
 2017-02-16 24qwerty    
 2017-02-16 25qwerty    
 2017-02-16 26qwerty    
 2017-02-16 27qwerty    
 2017-02-16 28qwerty       
 2017-02-16 1qwerty    
 2017-02-16 24qwerty   Highlighted
 2017-02-16 29qwerty    
 2017-02-15 1qwerty 
 2017-02-07 6qwerty   Should be Highlighted
 2017-02-07 6qwerty     
 2017-02-07 30qwerty    
 2017-02-07 31qwerty    
 2017-02-07 19qwerty    
 2017-02-07 32qwerty    
 2017-02-06 6qwerty 
 2017-02-01 33qwerty    
 2017-02-01 33qwerty   Should be Highlighted
 2017-02-01 34qwerty

任何帮助都一如既往地受到赞赏！

Answer 1

如果你把日期保持在正常状态（升序或降序），如果你没有 - 只是按顺序排序，那么这不是一项艰巨的任务！

所以让我们像你的数据示例一样绑定降序！在这种情况下，我的输入如下所示：

请注意，在我的示例中，我使用字典对象来跟踪我搜索的项目。

要使用字典对象，您需要参考Microsoft Scripting Runtime！

示例例程：

Option Explicit


Sub Test()
    Dim WS As Worksheet

    Dim DataRange As Range
    Dim DataDict As Dictionary
    Dim RawData As Variant

    Dim CurrentSearch As Range
    Dim TestPrevSearch As Range
    Dim FirstSearch As Range

    Dim CurrentDate As Date

    Dim LastRow As Long
    Dim i As Long

    Dim DebMsg As String

    Set WS = ActiveSheet                                   'or whatever sheet your want
    Set DataDict = New Dictionary                          'setting-up a dictionary

    With WS
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set DataRange = .Range("A1:A" & LastRow)
    End With

    RawData = Application.Transpose(DataRange)             'transposing raw data

    If Not IsArray(RawData) Then _
            Exit Sub

    'iterating over each qwerties
    For i = LBound(RawData) To UBound(RawData)
        Debug.Print "Search for " & RawData(i)

        If Not DataDict.Exists(RawData(i)) Then
            'Get first search
            Set TestPrevSearch = Nothing
            Set CurrentSearch = DataRange.Find(What:=RawData(i), LookIn:=xlValues, SearchDirection:=xlNext, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    MatchCase:=False, SearchFormat:=False)

            If Not CurrentSearch Is Nothing Then

                'Maybe it's a bug - but sometimes it's start search from second occurence...
                Set TestPrevSearch = DataRange.FindPrevious(After:=CurrentSearch)
                If Not TestPrevSearch Is Nothing Then
                    If TestPrevSearch.Row < CurrentSearch.Row Then
                        Debug.Print "Bug search fixed......"
                        Set CurrentSearch = TestPrevSearch
                    End If
                End If

                CurrentDate = CurrentSearch.Offset(ColumnOffset:=1).Value
                Debug.Print vbTab & "Found in  " & CurrentSearch.Address & vbTab & vbTab & "Date is " & CurrentDate _
                        & vbTab & vbTab & "Reference date"

                Call DataDict.Add(Key:=RawData(i), Item:=CurrentDate)

                Set FirstSearch = CurrentSearch
                Do
                    'Get next search in loop
                    Set CurrentSearch = DataRange.FindNext(After:=CurrentSearch)

                    If Not CurrentSearch Is Nothing Then
                        If CurrentSearch.Address = FirstSearch.Address Then
                            Exit Do
                        Else
                            CurrentDate = CurrentSearch.Offset(ColumnOffset:=1).Value

                            DebMsg = vbTab & "Found in " & CurrentSearch.Address & vbTab & vbTab & "Date is " & CurrentDate


                            'If CurrentDate older then date in a dict
                            If CurrentDate < DataDict(RawData(i)) Then

                                'Check if it was yesterday (if you need to check for tomorrow - get rid off "-" sign)
                                If CurrentDate = DateAdd("d", -1, DataDict(RawData(i))) Then
                                    CurrentSearch.Interior.ColorIndex = 3
                                    DebMsg = DebMsg & vbTab & vbTab & "Highlighted (Yesterday to reference)"
                                    'If it even older...
                                Else
                                    DataDict(RawData(i)) = CurrentDate
                                    DebMsg = DebMsg & vbTab & vbTab & "New Reference (Older then reference)"
                                End If

                                'If Dates are equal
                            ElseIf CurrentDate = DataDict(RawData(i)) Then
                                CurrentSearch.Interior.ColorIndex = 3
                                DebMsg = DebMsg & vbTab & vbTab & "Highlighted (Equal to reference)"
                                'Rewrite date in dictionary if younger
                            Else
                                DataDict(RawData(i)) = CurrentDate
                                DebMsg = DebMsg & vbTab & vbTab & "New Reference (Younger then reference)"
                            End If
                            Debug.Print DebMsg
                        End If
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Else
            Debug.Print vbTab & "already found"
        End If
    Next

End Sub

<强>输出：

奖金输出（立即检查）：

如果你要编辑我的逻辑会有所帮助！

<强>摘要：

迭代qwerty条目而不是100行明显更快！
我们需要（不是真的，但排序数据更容易）首先对数据进行排序！

有用的链接：

Does vba have dictionary structure

.Find and .FindNext in Excel VBA

Find last row, column or last cell

在时间范围内查找字符串

1 个答案: