Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Color Cells in VBA

Posted on 2014-01-28
8
Medium Priority
?
420 Views
Last Modified: 2014-01-28
Hi,

I have a working macro that looks at column B on the active sheet and colors any cells that match a value in Column C on another sheet ("Sheet1").

The list in column C on Sheet1 is fluid so it's functional to have the list there to add/delete from it on the fly.

Now I find I need to color some cells another color by putting another list of values in Column E. I copied the code, changed the references and it almost works.

The problem is that the values on the active workbook that match in C get the color 28 assigned to them changed to 31 after VBA matches the data to column E values. Can't figure out why that is happening. Code is below.

Sub Test1()' 'colors cells (color 28) on active sheet when cell value in column B matches value found in column C on "sheet1"

Dim lRow As Long, Row2 As Long
Dim cell As Range, cell2 As Range, MR As Range, MR2 As Range
lRow = Range("B" & Rows.Count).End(xlUp).Row
Set MR = Range("B2:B" & lRow)
Row2 = Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
Set MR2 = Worksheets("Sheet1").Range("C1:C" & Row2)
For Each cell In MR
    If cell.Value <> "" Then
        For Each cell2 In MR2
            If cell2 <> "" Then
                If InStr(1, cell, cell2, 1) Then
                    cell.Interior.ColorIndex = 28
                    Exit For
                End If
            End If
        Next
    End If
Next
End Sub

Sub Test2() 'colors cells (color 31) on active sheet when cell value in column B matches value found in column E on "sheet1"

Dim lRow As Long, Row2 As Long
Dim cell As Range, cell2 As Range, MR As Range, MR2 As Range
lRow = Range("B" & Rows.Count).End(xlUp).Row
Set MR = Range("B2:B" & lRow)
Row2 = Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row
Set MR2 = Worksheets("Sheet1").Range("E1:E" & Row2)
For Each cell In MR
    If cell.Value <> "" Then
        For Each cell2 In MR2
            If cell2 <> "" Then
                If InStr(1, cell, cell2, 1) Then
                    cell.Interior.ColorIndex = 31
                    Exit For
                End If
            End If
        Next
    End If
Next

End Sub

Maybe there is a way to combine the two parts?

Thanks in advance,

swjtx99
0
Comment
Question by:swjtx99
  • 4
  • 4
8 Comments
 
LVL 39

Expert Comment

by:nutsch
ID: 39815555
Why not use conditional formatting?
0
 

Author Comment

by:swjtx99
ID: 39815623
Need to be done in VBA. This updates a daily report so each day is a different data set. Don't want to go through the process of conditional formatting each day and the lists on Sheet1 change frequently.
0
 
LVL 39

Expert Comment

by:nutsch
ID: 39815713
Are your cells in column B text, numbers, formulas?

Try this update in the meantime:

Sub TestCombo() ' '

Dim rgLoopB As Range, rgLoopC As Range, rgLoopE As Range
Dim rgB As Range, rgC As Range, rgE As Range

Set rgB = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set rgC = Worksheets("Sheet1").Range("C1:C" & Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row)
Set rgE = Worksheets("Sheet1").Range("E1:E" & Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row)

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

For Each rgLoopB In rgB.Cells
    If rgLoopB.Value <> "" Then
        
        For Each rgLoopC In rgC
            If rgLoopC <> "" Then
                If InStr(1, rgLoopB, rgLoopC, 1) Then
                    rgLoopB.Interior.ColorIndex = 28
                    GoTo nxtBCell
                End If
            End If
        Next
        
        For Each rgLoopE In rgE
            If rgLoopE <> "" Then
                If InStr(1, rgLoopB, rgLoopE, 1) Then
                    rgLoopB.Interior.ColorIndex = 31
                    GoTo nxtBCell
                End If
            End If
        Next
        
nxtBCell:
    End If
Next

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Open in new window

0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:swjtx99
ID: 39816134
!!!!!
Works almost perfectly! Amazing!

One issue is a Cell contains two words:

PEPSI FREE
PEPSI

The code colored both when the only exact match was Pepsi Free.

The data is a mix of letters, numbers and spaces with some occasional dashes. Examples:

55451-RC COLA
733499
PEPSI - 41255
45COKE89
0
 
LVL 39

Expert Comment

by:nutsch
ID: 39816157
You're using instr(), so it will pick up partial matches. I'm not sure what your different datas are and what results you're looking for. Can you precise?

Tell me for that issue:
- the value in column B
- the matched value in column C or E
- the result you get
- the result you want.

Thomas
0
 

Author Comment

by:swjtx99
ID: 39816289
Hi Thomas,

Value in Column B is PEPSI
The Value in column C or E is PEPSI FREE
When this is the case, I do not want a match. Currently I am getting a match

When there is an exact match, it should color the cell in column B the appropriate color (28 if the match is from C or 31 if the match is from E)

I hope that is clear. Please let me know if it is not.

Thanks for your help,

swjtx99
0
 
LVL 39

Accepted Solution

by:
nutsch earned 2000 total points
ID: 39816338
Does this work?
Sub TestCombo() ' '

Dim rgLoopB As Range, rgLoopC As Range, rgLoopE As Range
Dim rgB As Range, rgC As Range, rgE As Range

Set rgB = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set rgC = Worksheets("Sheet1").Range("C1:C" & Worksheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row)
Set rgE = Worksheets("Sheet1").Range("E1:E" & Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Row)

'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

For Each rgLoopB In rgB.Cells
    If rgLoopB.Value <> "" Then
        
        For Each rgLoopC In rgC
            If rgLoopC <> "" Then
                If rgLoopB=rgLoopC, Then
                    rgLoopB.Interior.ColorIndex = 28
                    GoTo nxtBCell
                End If
            End If
        Next
        
        For Each rgLoopE In rgE
            If rgLoopE <> "" Then
                If rgLoopB=rgLoopE Then
                    rgLoopB.Interior.ColorIndex = 31
                    GoTo nxtBCell
                End If
            End If
        Next
        
nxtBCell:
    End If
Next

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Open in new window

0
 

Author Closing Comment

by:swjtx99
ID: 39816458
Hi Thomas,

Yes Sir, Works perfectly. Pretty amazing solution and I sincerely thank you for the help.

If you're ever in Texas, the drinks are on me.

Regards,

swjtx99
0

Featured Post

Ask an Anonymous Question!

Don't feel intimidated by what you don't know. Ask your question anonymously. It's easy! Learn more and upgrade.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft's Excel has many features that most people will never need nor take advantage of.  Conditional formatting is one feature that you may find a necessity once you start using it.
Windows Explorer let you handle zip folders nearly as any other folder: Copy, move, change, and delete, etc. In VBA you can also handle normal files and folders, but zip folders takes a little more - and that you'll find here.
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

916 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question