Solved

Color Cells in VBA

Posted on 2014-01-28
8
415 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
Industry Leaders: 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 500 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

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!

Question has a verified solution.

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

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

735 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