Finding Values and Conidtionally Formatting them Based on Ranges with VBA

[turner38]

Hello All,

I have the following data sets:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	Name	Score	Time	Place		Validation Table	Score	Score	Time	Time	Place	Place
2	Steve	95	3	4			Low	High	Low	High	Low	High
3	John	91	3.5	5		Steve	80	100	1	5	8	2
4	Kevin	98	2	3		John	75	100	1	4	8	2
5	Dennis	100	1.5	1		Kevin	90	100	1	6	8	2
6	Rick	85	4.5	7		Dennis	95	100	2	6	8	2
7	Jeff	88	4	6		Rick	80	100	0.5	6	8	2
8	Paul	75	5	8		Jeff	80	90	0.5	6	8	2
9	Peter	99	1.7	2		Paul	78	90	0.5	6	7	1
10	Robert	100	1.5	1		Peter	87	90	2	4	7	1
11						Robert	89	90	1	3	7	1
Sheet1

Excel 2007



I want to use VBA to automatically flag data in the left table for values under the "Score", "Time", and "Place" columns that fall outside (either below the low value or above the high value) the ranges set for each person in the validation table (Righ-side table). The flag data I want to show by bolding the font and changing the font color to red.

My plan is to use this function to automatically audit my data set for good data integrity. I will have about 10,000+ lines of data so I really prefer to use VBA if possible. I know I could manually set the conditional format but I will be constantly loading new data to the sheet each week and want this feature to automatically flag the "abnormal" data after I paste it.

I have looked at some threads and I think the Find function in VBA will help locate the value, but I don't know how to tie in the ranges and conditional format.

Any help, thoughts, or comments are greatly appreciated!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG23Aug31
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng1    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng2    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] c       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
Application.ScreenUpdating = False
[COLOR="Navy"]Set[/COLOR] Rng1 = Range(Range("F2"), Range("F" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng2 = Range(Range("AB3"), Range("AB" & Rows.Count).End(xlUp))
  ReDim Ray(1 To 16)
    [COLOR="Navy"]With[/COLOR] Rng1.Resize(, 9)
        .Font.ColorIndex = 1
        .Font.Bold = False
    [COLOR="Navy"]End[/COLOR] With
Rng1.Offset(, 9).ClearContents
[COLOR="Navy"]Set[/COLOR] Rng = Union(Rng2, Rng1)
[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] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]If[/COLOR] Dn.Column = 28 [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]For[/COLOR] n = 2 To 17
                    Ray(n - 1) = Dn(, n)
                [COLOR="Navy"]Next[/COLOR] n
                    .Add Dn.Value, Ray
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Else[/COLOR]
           [COLOR="Navy"]If[/COLOR] Dn.Column = 6 [COLOR="Navy"]Then[/COLOR]
                c = 2
                q = .Item(Dn.Value)
                [COLOR="Navy"]For[/COLOR] n = 2 To 9
                    c = c - 1
                    [COLOR="Navy"]If[/COLOR] Not Dn(, n) = vbNullString [COLOR="Navy"]Then[/COLOR]
                    [COLOR="Navy"]If[/COLOR] Dn(, n) < q(n - c) Or Dn(, n) > q(n - c + 1) [COLOR="Navy"]Then[/COLOR]
                         [COLOR="Navy"]With[/COLOR] Dn(, n)
                            .Font.ColorIndex = 3
                            .Font.Bold = True
                            Dn(, 10) = "X"
                     [COLOR="Navy"]End[/COLOR] With
                    [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR] n
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[turner38]

Mick,

It works perfectly! If I want to move my "Valiation Table" (Columns AB to AR) to it's own sheet ( Sheet Name is "Validation Table"), how would I modify your code to reflect that? I assume I have to change the Rng2 reference. I tried to make the reference myself but I keep getting errors.

Any advice?

Thanks,

 

[MickG]

Hi, Alter "Rng2 " to:-
NB:- The extra Dots in front of the words "Range"

With Sheets("Validation.Table")
Set Rng2 = .Range(.Range("AR3"), .Range("AR" & Rows.Count).End(xlUp))
End with

Mick

 

[turner38]

Hi Mick,

Thanks. I appreciate all your help!

 

[turner38]

Mick,

I made the reference change to Rng2, but I am getting an "Method Union of Object_Global failed" error on the latter portio of the code.

Set Rng = Union(Rng2, Rng1)

 

[MickG]

Sorry, These things are always more problematic than you first think.
Try this with new "Validation Data" sheet :-

[COLOR=navy]Sub[/COLOR] MG28Aug10
[COLOR=navy]Dim[/COLOR] Rng         [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn          [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rng1        [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Rng2        [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] c           [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]Dim[/COLOR] nShtRng     [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]Dim[/COLOR] R           [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
Application.ScreenUpdating = False
[COLOR=navy]Set[/COLOR] Rng1 = Range(Range("F2"), Range("F" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] Sheets("Validation Data")
[COLOR=navy]Set[/COLOR] Rng2 = .Range(.Range("AR3"), .Range("AR" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
  ReDim Ray(1 To 16)
    [COLOR=navy]With[/COLOR] Rng1.Resize(, 9)
        .Font.ColorIndex = 1
        .Font.Bold = False
    [COLOR=navy]End[/COLOR] With
Rng1.Offset(, 9).ClearContents
   nShtRng = Array(Rng2, Rng1)
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    [COLOR=navy]For[/COLOR] R = 0 To 1
    [COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] nShtRng(R)
        [COLOR=navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=navy]Then[/COLOR]
            [COLOR=navy]If[/COLOR] R = 0 [COLOR=navy]Then[/COLOR]
                [COLOR=navy]For[/COLOR] n = 2 To 17
                    Ray(n - 1) = Dn(, n)
                [COLOR=navy]Next[/COLOR] n
                    .Add Dn.Value, Ray
            [COLOR=navy]End[/COLOR] If
        [COLOR=navy]Else[/COLOR]
           [COLOR=navy]If[/COLOR] R = 1 [COLOR=navy]Then[/COLOR]
                c = 2
                q = .Item(Dn.Value)
                [COLOR=navy]For[/COLOR] n = 2 To 9
                    c = c - 1
                    [COLOR=navy]If[/COLOR] Not Dn(, n) = vbNullString [COLOR=navy]Then[/COLOR]
                    [COLOR=navy]If[/COLOR] Dn(, n) < q(n - c) Or Dn(, n) > q(n - c + 1) [COLOR=navy]Then[/COLOR]
                         [COLOR=navy]With[/COLOR] Dn(, n)
                            .Font.ColorIndex = 3
                            .Font.Bold = True
                            Dn(, 10) = "X"
                     [COLOR=navy]End[/COLOR] With
                    [COLOR=navy]End[/COLOR] If
                    [COLOR=navy]End[/COLOR] If
                [COLOR=navy]Next[/COLOR] n
            [COLOR=navy]End[/COLOR] If
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]Next[/COLOR] R
[COLOR=navy]End[/COLOR] With
Application.ScreenUpdating = True
MsgBox "Run!!"
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[turner38]

Mick,

That worked.

Thanks,