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.
BCDE
231000xx02022018092900
242100xxPG001
253000xx1
263000xx2
273000xx3
282100xxPG102
292100xxPG001
303000xx1
313000xx2

<tbody>
</tbody>



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

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
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.

10001.0GAMASUA08302018143227
21001.00000000006PGIL
21001.00000000005PGIL
30001.000000000051
21001.00000000003PGIL
21001.00000000004PGIL
21001.00000000002PGIL
21001.00000000000PGIL
21001.00000000001PGIL
30001.000000000011
30001.000000000071
30001.000000000062
30001.000000000063
30001.000000000064
30001.000000000031
30001.000000000041
30001.000000000021
30001.000000000001
30001.000000000002
50007

<tbody>
</tbody>
 
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
116
Alex Blakenburg
A
D
  • Question
Find matching value in table, check if specific cell in same row is empty, find next if not
Replies
0
Views
249
dubyarly
D
H
  • Solved
Macro to sort block of data
2
Replies
15
Views
969
Joe4
Joe4
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
309
B-radK
B
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
503
AndyEd
A

Forum statistics

Threads
1,216,115
Messages
6,128,919
Members
449,478
Latest member
Davenil

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