Finding a string in a time range

Question

How could I highlight a duplicate part number within a time range, of the same date, or the next day.

 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

So in this instance, the 5th, 8th and 9th line would be highlighted as these are within the same day or on the next day of the part number being searched for. I would need to create a loop that would do this for each line, potentially 100 rows.

Here is some more data, ive put in what works as being highlighted and where it has not worked as Should be higlighted, thanks

 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

Any help is much appreciated as always!

CommonSense · Accepted Answer

it's not a hard task if you keep your dates in order (ascending or descending) and if you don't - just sort with order first!

So let's bind to descending order like in your data example! My input in that case looks like this:

Note, that in my example I use dictionary object to track items, that I searched for.

To use a dictionary object you need reference to Microsoft Scripting Runtime!

Example routine:

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

Output:

Bonus output (check your immediate):

It would help if you gonna edit my logic!

Summary:

Iterating over qwerty entries instead of 100 lines is noticeably faster!
We need (not really, but it's easier with sorted data) to sort our data first!

Useful links:

Does vba have dictionary structure

.Find and .FindNext in Excel VBA

Find last row, column or last cell

Finding a string in a time range

Answers (1)

Related Questions