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
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG12Apr27
[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] Temp [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Const num = 2100
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
[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.Value = num [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Temp = Dn
       [COLOR="Navy"]If[/COLOR] Not Temp [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
           [COLOR="Navy"]If[/COLOR] Not .Exists(Temp.Address) [COLOR="Navy"]Then[/COLOR]
               .Add Temp.Address, Nothing
           [COLOR="Navy"]Else[/COLOR]
               [COLOR="Navy"]If[/COLOR] .Item(Temp.Address) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                  [COLOR="Navy"]Set[/COLOR] .Item(Temp.Address) = Dn
               [COLOR="Navy"]Else[/COLOR]
                 [COLOR="Navy"]Set[/COLOR] .Item(Temp.Address) = Union(.Item(Temp.Address), Dn)
               [COLOR="Navy"]End[/COLOR] If
           [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
   c = 0
    [COLOR="Navy"]If[/COLOR] Not .Item(K) [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K).Offset(, 3)
             c = c + 1
            [COLOR="Navy"]If[/COLOR] Not R.Value = c [COLOR="Navy"]Then[/COLOR]
                R.Interior.Color = vbRed
                R.Font.Color = vbYellow
                R.Font.Bold = True
          [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]Next[/COLOR] R
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick, it is very close, and this was my fault, I neglected to mention there are four (4) possible values in Column-B, 1000, 2100, 3000 and 5000. Your code worked on my test data, but it also highlighted my data line with a 5000 value in Column-B, but nothing in Column-E. I want it to ignore the 1000 and 5000 data lines if possible.

I'm going to try and look at your code and see if I can fix that issue, but I am getting a little busy now at work, so hoping you can help me correct it.

Also, I updated the range from "B2" to "B23" as that is where my data starts, but that one I get.

Appreciate the help.

Phil
 
Upvote 0
I think this might be a bit closer !!!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG12Apr22
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nR [COLOR="Navy"]As[/COLOR] Range, Rng1 [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
Const num = 2100
[COLOR="Navy"]Set[/COLOR] Rng = Range("B23", Range("B" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
   [COLOR="Navy"]If[/COLOR] Dn.Value = num [COLOR="Navy"]Then[/COLOR]
      [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] nRng = Dn Else [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] nRng
    c = 1
    [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] Dn.Offset(c) = 3000
        [COLOR="Navy"]If[/COLOR] Rng1 [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Set[/COLOR] Rng1 = Dn.Offset(c) Else [COLOR="Navy"]Set[/COLOR] Rng1 = Union(Rng1, Dn.Offset(c))
        c = c + 1
    [COLOR="Navy"]Loop[/COLOR]
 [COLOR="Navy"]Next[/COLOR] Dn
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] nR [COLOR="Navy"]In[/COLOR] Rng1.Areas
      c = 0
      [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] nR
            c = c + 1
            [COLOR="Navy"]If[/COLOR] Not R.Offset(, 3).Value = c [COLOR="Navy"]Then[/COLOR]
                R.Offset(, 3).Interior.Color = vbRed
                R.Offset(, 3).Font.Color = vbYellow
                R.Offset(, 3).Font.Bold = True
          [COLOR="Navy"]End[/COLOR] If
      [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] nR
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG, or anyone, I need to update this slightly and I'm not sure I understand your code enough to do it on my own. I need to do the same thing as stated in the original post, see the quote below, but this is updated slightly, see below the quote.

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
Click to expand...

Now, the updated portion is that the 3000 records don't have to immediately follow a 2100 record, and the 3000 records don't have to be in order.

Also, column-D, not listed above with data in it, has a unique identifier to link a 2100 and 3000 record together. So here is an updated data set.

BCD
231000x02022018092900
242100x0001PG001
253000x00011
263000x00012
273000x00013
282100x0002PG102
292100x0003PG001
303000x00031
313000x00032

<tbody>
</tbody>


The records don't have to be listed like that, but the 2100 records will always precede a 3000 record.

So, I want to make sure that no 3000 record with the same unique identifier in column-D will have a duplicate value used in column-E and that the values in column-E always count up starting with 1, though they don't have to be listed in that specific order, just that if there are 3 values like on rows 25-27 in the data set above, that it has values 1, 2 & 3 in column-E for those 3000 records.


I hope that makes sense, and I hope someone can help.

Thanks,
Phil
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG19Sep50
[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]
[COLOR="Navy"]Set[/COLOR] Rng = Range("D23", Range("D" & Rows.Count).End(xlUp))
[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 = 3000 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                .Add Dn.Value, Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
            [COLOR="Navy"]End[/COLOR] If
         [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range, nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    nStr = "": c = 0
         nStr = "#" & Join(Application.Transpose(.Item(K).Offset(, 1)), "#") & "#"
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
              c = c + 1
              [COLOR="Navy"]If[/COLOR] InStr(nStr, "#" & c & "#") = 0 Or c = 1 And Not R.Offset(, 1).Value = 1 [COLOR="Navy"]Then[/COLOR]
                 R.Offset(, 1).Interior.Color = vbRed
                 R.Offset(, 1).Font.Color = vbYellow
                 R.Offset(, 1).Font.Bold = True
              [COLOR="Navy"]End[/COLOR] If
           [COLOR="Navy"]Next[/COLOR] R
    
    [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
I just tried it and I get an error saying Runtime error 13, Type Mistmatch, it is at this line:

Code: 
         nStr = "#" & Join(Application.Transpose(.Item(K).Offset(, 1)), "#") & "#"
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Question
Find matching value in table, check if specific cell in same row is empty, find next if not
Replies
0
Views
240
dubyarly
D
H
  • Solved
Macro to sort block of data
2
Replies
15
Views
923
Joe4
Joe4
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
262
B-radK
B
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
454
AndyEd
A
P
  • Question
Userform which stops duplicates entering data sheet
Replies
1
Views
412
RoryA
RoryA

Forum statistics

Threads
1,215,580
Messages
6,125,654
Members
449,245
Latest member
PatrickL

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