Simple Formula or VBA for Verifying Duplicates + one Criteria

[bradmsg]

Hi all,

I have been racking my brain for a couple weeks and need some help on this. Sometimes I over look over simple answer and I need someone to put me out of my misery.

Problem:

I have a 300,000 record long list. There are multiple duplicate numbers in column A and a date in column B. I need to check if ALL duplicates are within a certain date range (Between D2 and D4).

 

[Peter_SSs]

Sorry I’m having trouble with that program.

Do you mean XL2BB? What problem exactly? Mostly, if people describe exactly what goes wrong and at what stage of the instructions it happens the issue can be resolved.

 

[Peter_SSs]

For the 3-sheet scenario try this lightly tested version.

Sub All_Values_In_Date_Range()
  Dim d1 As Object, d2 As Object
  Dim a As Variant, aRws As Variant
  Dim dStart As Date, dEnd As Date
  Dim i As Long, FirstRow As Long, LastRow As Long
 
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1") '<-Check sheet name & cell addresses
    dStart = .Range("D4").Value
    dEnd = .Range("D6").Value
  End With
  With Sheets("Sheet2") '<-Check sheet name & columns
    FirstRow = 4 '<- First row of actual data
    LastRow = .Range("F" & Rows.Count).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(" & FirstRow & ":" & LastRow & ")"), Array(6, 16)) '<- 6 & 16 = cols F & P
  End With
  For i = 1 To UBound(a)
    If d2.exists(a(i, 1)) Then
      If d1.exists(a(i, 1)) Then d1.Remove a(i, 1)
    Else
      If a(i, 2) < dStart Or a(i, 2) > dEnd Then
        d2(a(i, 1)) = 1
        If d1.exists(a(i, 1)) Then d1.Remove a(i, 1)
      Else
        d1(a(i, 1)) = 1
      End If
    End If
  Next i
  With Sheets("Sheet3").Columns("A")  '<-Check sheet name & column for results
    .EntireColumn.ClearContents
    .Cells(1).Value = "Results"
    If d1.Count > 0 Then
      With .Resize(d1.Count).Offset(1)
        .Value = Application.Transpose(d1.Keys)
        .Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
      End With
    Else
       .Cells(2).Value = "N/A"
    End If
  End With
End Sub

bradmsg_1.xlsm
	D
1
2
3	Start
4	25/02/2022
5	End
6	1/03/2022
Sheet1

bradmsg_1.xlsm
	F										P
1
2
3
4	1										25/02/2022
5	2										26/02/2022
6	3										27/02/2022
7	4										28/02/2022
8	5										1/03/2022
9	6										2/03/2022
10	7										3/03/2022
11	8										4/03/2022
12	9										6/03/2022
13	1										6/03/2022
14	3										6/03/2022
15
Sheet2

bradmsg_1.xlsm
	A
1	Results
2	2
3	4
4	5
5
Sheet3

 

[bradmsg]

Sir, you are a gentleman. When I am able to get back to where my sheets are, I will try this out. Thank you again for helping me out!

Best regards until tomorrow,

Brad (Navy vet who can’t program his way out of a box!)

 

[frabulator]

EDIT -
I noticed I messed something up and removed it

 

[frabulator]

As a way to redeem myself, I have modified my code.

Just ran the code again, and tested it out on a 30,000K data set. A complete scan with all unique values ran between 1 second to 20 seconds. I would suspect that this takes between 5 seconds to 1 minute on a 300k data set.

You can set your mins and max at the top of the code.

There will be a message box that pops up when completed. You can also move the mouse, (cursor will be a waiting sign) and even stop the script if it starts to take too long.

Sub LookForDupes()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim min As Integer
    min = 2
    Dim max As Long
    max = 30000
    
    Dim C1 As Collection
    
    Set C1 = New Collection
    
    ws.Range("F" & min + 1 & ":F" & max).Value = ""       'clears cells
    
    Dim SD As Date
    Dim ED As Date
    Dim TD As Date
    
    SD = ws.Cells(2, 4).Value
    ED = ws.Cells(4, 4).Value
    
    Dim V As String
    
    Application.Cursor = xlWait
    ScreenUpdating = False
    
    For i = min To max
        DoEvents
        
        Dim C2 As Collection
        Set C2 = New Collection
        
        
        V = ""
        TD = ws.Cells(i, 2).Value
        If TD >= SD And TD <= ED Then       'its a match, so check
            V = ws.Cells(i, 1).Value
            If V <> "" Then
            
                
                'now we need to loop and see if there are any more
                Dim Alone As Boolean
                Alone = False
                        Dim RNG As Range
                        Set RNG = ws.Range("A" & min & ":A" & max)
                        Dim Cell As Range
                        Set Cell = RNG.Find(What:=V, LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)
                        
                        Do Until Cell Is Nothing Or Alone = True
                            Dim r As Long
                            r = Cell.Row
                            TD = ws.Cells(r, 2).Value
                            If TD >= SD And TD <= ED Then
                            Else
                                Alone = True
                            End If
                            Set Cell = Nothing
                            Set RNG = ws.Range("A" & r + 1 & ":A" & max)
                            On Error GoTo SKip
                            Set Cell = RNG.Find(What:=V, LookIn:=xlFormulas, LookAt:=xlWhole, MatchCase:=False)

                        Loop
SKip:
On Error GoTo 0

                
                If Alone = False Then
                    Dim F As Boolean
                    F = False
                    For x = 1 To C1.Count            'checks to see if it is there already
                        On Error GoTo notthere
                        If C1(x) = V Then
                            F = True
                            Exit For
                        End If
notthere:
On Error GoTo 0
                    Next
                    
                    If F = False Then
                        C1.Add (V)
                    End If
                End If
            End If
            
            
        End If
    Next
    
    For i = 1 To C1.Count
        ws.Cells(i + 2, 6).Value = C1(i)
        DoEvents
    Next
        
    
    ScreenUpdating = True
    Application.Cursor = xlDefault
    MsgBox ("Done")
End Sub

 

[Peter_SSs]

Just ran the code again, and tested it out on a 30,000K data set. A complete scan with all unique values ran between 1 second to 20 seconds. I would suspect that this takes between 5 seconds to 1 minute on a 300k data set.

Hmm, that does not gel with me. 'Actual' run-time will of course depend on both the particular sample data and the physical machinery the code is running on. However, when I ran this new code on the same 35,000 row data that I used prior to post 15 when I reported nearly half an hour, this time I gave up after waiting about 20 minutes.

Just wondering if you did a time comparison with your data using the post 18 code?

As a side issue, I would strongly recommend setting your vba to include Option Explicit by default.

It would stop you making inadvertent errors like this, which does not turn screen updating off.

 

[frabulator]

Hmm, that does not gel with me. 'Actual' run-time will of course depend on both the particular sample data and the physical machinery the code is running on. However, when I ran this new code on the same 35,000 row data that I used prior to post 15 when I reported nearly half an hour, this time I gave up after waiting about 20 minutes.

Just wondering if you did a time comparison with your data using the post 18 code?

As a side issue, I would strongly recommend setting your vba to include Option Explicit by default. View attachment 84228
It would stop you making inadvertent errors like this, which does not turn screen updating off.

View attachment 84229

I know times will vary, but 20 minutes?

And no, I missed that. I guess it didnt load or I skipped over it. What I did was generated random dates within a 25 day window and then generated random values between 1 and 100, then 1 and 10 for the placements. I then placed these values in a spreadsheet going up to 29165 rows. Both times was under 1 minute for me. I thought this would be a good indication of the type of formula that would be ran.

BUT, going back and looking at it, I understand that my focus was on one sheet, not the others.

So! My post is now not applicable

I dont understand what you are referring to with the screenupdating? In all my testing I have done, the addition of turning screenupdating off greatly reduces the amount of time and processing cost of VBA code being ran. Could you please explain what you mean?

 

[Peter_SSs]

I dont understand what you are referring to with the screenupdating? In all my testing I have done, the addition of turning screenupdating off greatly reduces the amount of time and processing cost of VBA code being ran. Could you please explain what you mean?

Put this MsgBox line into your code where shown and run the code. What does the message box say?

Application.Cursor = xlWait
ScreenUpdating = False
MsgBox "Currently screen updating is: " & Application.ScreenUpdating

 

[frabulator]

Put this MsgBox line into your code where shown and run the code. What does the message box say?

Application.Cursor = xlWait
ScreenUpdating = False
MsgBox "Currently screen updating is: " & Application.ScreenUpdating

Oh yeah, I over looked the 'Application.'
Habit of programming in .Net. You assume things that are newer are in VBA. My bad
I also didnt know about the option you outlined before. I have always just rocked the default settings

 

[Peter_SSs]

I also didnt know about the option you outlined before.

If you had forced Option Explicit with the setting that I showed, then the ScreenUpdating = False line would have been flagged as a problem, along with some other line(s), but I think a much safer practice to declare all variables.