VBA assistance to check values aren't duplicated for a specific block of data

P

philwojo

Well-known Member
Joined
May 10, 2013
Messages
533
Hello, I am looking for some assistance on trying to come up with some VBA code to check that an ID number isn't repeated for a particular block of data. The data block sizes can change though.

Here is a sample of the data.
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD]23[/TD]
[TD]1000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]02022018092900[/TD]
[/TR]
[TR]
[TD]24[/TD]
[TD]2100[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]PG001[/TD]
[/TR]
[TR]
[TD]25[/TD]
[TD]3000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]26[/TD]
[TD]3000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]27[/TD]
[TD]3000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]28[/TD]
[TD]2100[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]PG102[/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD]2100[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]PG001[/TD]
[/TR]
[TR]
[TD]30[/TD]
[TD]3000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]31[/TD]
[TD]3000[/TD]
[TD]x[/TD]
[TD]x[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]



I want to make sure that any row that has a "3000" in it has a unique value. But the 3000 records are driven by and linked to the preceding 2100 record. And, as it shows in the data, a 2100 record does NOT have to have a 3000 record to go with it.

So if I find a 2100 record followed by a 3000 record I then need to look at column-E and make sure that the sequence starts with 1 and does not repeat for any 3000 record under that 2100 record. If it does, I want to highlight the cell red and turn the font a bold yellow color.

The data size can vary and it needs to be able to account for the data in column-E being consecutive, no skips or jumps in that sequence.

Thanks for any assistance.

Phil
 
Sort by date Sort by votes
Ok figured out the Resize, I just changed it to Offset.

I have to do a few more tests ,but I think it is working, I'll follow-up once I have time to go through it though.

Phil
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Ok, I updated the code slightly as it didn't have my error counter in it (other code I use). But when I put in a few lines it only seems to be counting everything one time, not multiple as I would expect.

Here is my updated code, my additions in red:

Code: 
Sub MG20Sep05()' Data starts "B23", Rng reference starts "D23"
Dim Rng As Range, Dn As Range, n As Long, Num As Long, R1 As Range, R2 As Range, Q As Variant
Set Rng = Range("D23", Range("D" & Rows.Count).End(xlUp))
ErrorCount = 0
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
   If Dn.Offset(, -2).Value = 2100 Or Dn.Offset(, -2).Value = 3000 Then
        Num = IIf(Dn.Offset(, -2).Value = 2100, 0, 1)
        If Not .Exists(Dn.Value) Then
            
            If Dn.Offset(, -2).Value = 2100 Then
                    Set R1 = Dn.Offset(, -2)
            ElseIf Dn.Offset(, -2).Value = 3000 Then
                    Set R2 = Dn.Offset(, -2)
            End If
            .Add Dn.Value, Array(R1, R2)
        Else
            Q = .Item(Dn.Value)
                If Q(Num) Is Nothing Then
                    Set Q(Num) = Dn.Offset(, -2)
                Else
                    Set Q(Num) = Union(Q(Num), Dn.Offset(, -2))
                End If
            .Item(Dn.Value) = Q
        End If
    End If
Set R1 = Nothing: Set R2 = Nothing
Next
Dim K As Variant, c As Long, p As Range, A As Long, t, tt
    For Each K In .keys
        c = 0: A = 0
        If Not .Item(K)(0) Is Nothing Then
            A = .Item(K)(0).Count 'IIf(.Item(K)(0) Is Nothing, 0, .Item(K)(0).Count)
        Else
            A = 0
        End If
            If Not .Item(K)(1) Is Nothing Then
                If .Item(K)(0) Is Nothing Or Not .Item(K)(1)(1).Offset(, 3).Value = 1 Then
[COLOR=#ff0000]                    ErrorCount = ErrorCount + 1[/COLOR]
                    .Item(K)(1).Offset(, 3).Interior.Color = vbRed
                    .Item(K)(1).Offset(, 3).Font.Color = vbYellow
                    .Item(K)(1).Offset(, 3).Font.Bold = True
[COLOR=#ff0000]                    .Item(K)(1).Offset(, -1).Interior.Color = vbRed[/COLOR]
[COLOR=#ff0000]                    .Item(K)(1).Offset(, -1).Font.Color = vbYellow[/COLOR]
[COLOR=#ff0000]                    .Item(K)(1).Offset(, -1).Font.Bold = True[/COLOR]
[COLOR=#ff0000]                    .Item(K)(1).Offset(, -1).Value = "Errors in this Row"[/COLOR]
            Else
                    For Each Dn In .Item(K)(1)
                        c = c + 1
                        If Not Dn.Offset(, 3).Value = c Then
[COLOR=#ff0000]                            ErrorCount = ErrorCount + 1[/COLOR]
                            Dn.Offset(, 3).Interior.Color = vbRed
                            Dn.Offset(, 3).Font.Color = vbYellow
                            Dn.Offset(, 3).Font.Bold = True
[COLOR=#ff0000]                            .Item(K)(1).Offset(, -1).Interior.Color = vbRed[/COLOR]
[COLOR=#ff0000]                            .Item(K)(1).Offset(, -1).Font.Color = vbYellow[/COLOR]
[COLOR=#ff0000]                            .Item(K)(1).Offset(, -1).Font.Bold = True[/COLOR]
[COLOR=#ff0000]                            .Item(K)(1).Offset(, -1).Value = "Errors in this Row"[/COLOR]
                        End If
                    Next Dn
            End If
        End If
Next K
End With
[COLOR=#ff0000]MsgBox "Total Number of Potential Errors Found = " & ErrorCount & Chr(10) & Chr(10) & "Also,check the 'Raw Data' tab for potential comma counts issues.", vbInformation[/COLOR]
End Sub

At the end I only get 2 errors on one test I am doing, but I would expect it to show 4, here is the data set for that. The one's in red are what get highlighted, but the ErrorCount only shows as "2", I would expect it to be 4, but maybe I'm not thinking about it correctly.

[TABLE="class: grid, width: 461"]
<tbody>[TR]
[TD]1000[/TD]
[TD]1.0[/TD]
[TD]GAMASUA[/TD]
[TD]08302018143227[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000006[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000005[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000005[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000003[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000004[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000002[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000000[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]2100[/TD]
[TD]1.0[/TD]
[TD]0000000001[/TD]
[TD]PGIL[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000001[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000007[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000006[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000006[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000006[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000003[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000004[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000002[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000000[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]3000[/TD]
[TD]1.0[/TD]
[TD]0000000000[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]5000[/TD]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Try this, See remarks in code!!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG20Sep02
'[COLOR="Green"][B]modified[/B][/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R1 [COLOR="Navy"]As[/COLOR] Range, R2 [COLOR="Navy"]As[/COLOR] Range, Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] ErrorCount [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("D23", Range("D" & Rows.Count).End(xlUp))
ErrorCount = 0
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   [COLOR="Navy"]If[/COLOR] Dn.Offset(, -2).Value = 2100 Or Dn.Offset(, -2).Value = 3000 [COLOR="Navy"]Then[/COLOR]
        Num = IIf(Dn.Offset(, -2).Value = 2100, 0, 1)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            
            [COLOR="Navy"]If[/COLOR] Dn.Offset(, -2).Value = 2100 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] R1 = Dn.Offset(, -2)
            [COLOR="Navy"]ElseIf[/COLOR] Dn.Offset(, -2).Value = 3000 [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] R2 = Dn.Offset(, -2)
            [COLOR="Navy"]End[/COLOR] If
            .Add Dn.Value, Array(R1, R2)
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.Value)
                [COLOR="Navy"]If[/COLOR] Q(Num) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] Q(Num) = Dn.Offset(, -2)
                [COLOR="Navy"]Else[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] Q(Num) = Union(Q(Num), Dn.Offset(, -2))
                [COLOR="Navy"]End[/COLOR] If
            .Item(Dn.Value) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Set[/COLOR] R1 = Nothing: [COLOR="Navy"]Set[/COLOR] R2 = Nothing
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] Range, A [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t, tt
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
        
        c = 0: A = 0
        [COLOR="Navy"]If[/COLOR] Not .Item(K)(0) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
            A = .Item(K)(0).Count
            A = 0
        [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]If[/COLOR] Not .Item(K)(1) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]If[/COLOR] .Item(K)(0) [COLOR="Navy"]Is[/COLOR] Nothing Or Not .Item(K)(1)(1).Offset(, 3).Value = 1 [COLOR="Navy"]Then[/COLOR]
                    '[COLOR="Green"][B]This counts entire "3000" range when start cell is not 1 or there is no "2100"[/B][/COLOR]
                    If Not .Item(K)(1) Is Nothing Then '[COLOR="Green"][B]''''''''''''''[/B][/COLOR]
                        ErrorCount = ErrorCount + .Item(K)(1).Count '[COLOR="Green"][B]''''''''''[/B][/COLOR]
                    End If '[COLOR="Green"][B]''''''''''''[/B][/COLOR]
                    
                    .Item(K)(1).Offset(, 3).Interior.Color = vbRed
                    .Item(K)(1).Offset(, 3).Font.Color = vbYellow
                    .Item(K)(1).Offset(, 3).Font.Bold = True
'[COLOR="Green"][B]                    .Item(K)(1).Offset(, -1).Interior.Color = vbRed[/B][/COLOR]
'[COLOR="Green"][B]                    .Item(K)(1).Offset(, -1).Font.Color = vbYellow[/B][/COLOR]
'[COLOR="Green"][B]                    .Item(K)(1).Offset(, -1).Font.Bold = True[/B][/COLOR]
'[COLOR="Green"][B]                    .Item(K)(1).Offset(, -1).Value = "Errors in this Row"[/B][/COLOR]
            [COLOR="Navy"]Else[/COLOR]
                    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] .Item(K)(1)
                        c = c + 1
                        [COLOR="Navy"]If[/COLOR] Not Dn.Offset(, 3).Value = c [COLOR="Navy"]Then[/COLOR]
                           '[COLOR="Green"][B]This counts the errors when the "1,2,3, ect" count is incorrect[/B][/COLOR]
                               ErrorCount = ErrorCount + 1 '[COLOR="Green"][B]'''''[/B][/COLOR]
                            
                            Dn.Offset(, 3).Interior.Color = vbRed
                            Dn.Offset(, 3).Font.Color = vbYellow
                            Dn.Offset(, 3).Font.Bold = True
'[COLOR="Green"][B]                            .Item(K)(1).Offset(, -1).Interior.Color = vbRed[/B][/COLOR]
'[COLOR="Green"][B]                            .Item(K)(1).Offset(, -1).Font.Color = vbYellow[/B][/COLOR]
'[COLOR="Green"][B]                            .Item(K)(1).Offset(, -1).Font.Bold = True[/B][/COLOR]
'[COLOR="Green"][B]                            .Item(K)(1).Offset(, -1).Value = "Errors in this Row"[/B][/COLOR]
                        [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]Next[/COLOR] Dn
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
MsgBox "Total Number of Potential Errors Found = " & ErrorCount & Chr(10) & Chr(10) & "Also,check the '[COLOR="Green"][B]Raw Data' tab for potential comma counts issues"[/B][/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 
Upvote 0
Mick, thanks for your patients and all the assistance, this appears to be working as I had hoped for. I certainly would never have gotten to this point on my own.

Phil
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA Check for duplicate value and change if duplicate.
Replies
7
Views
531
Alex Blakenburg
A
D
  • Question Question
Find matching value in table, check if specific cell in same row is empty, find next if not
Replies
0
Views
412
dubyarly
D
H
  • Solved
Macro to sort block of data
2
Replies
15
Views
2K
Joe4
Joe4
B
  • Question Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
572
B-radK
B
O
  • Solved
VBA Code to Find Duplicate Values in a Range and Add a Number at the End
2
Replies
12
Views
805
OilEconomist
O

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top