Improve company productivity with a Business Account.Sign Up

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 424
  • Last Modified:

Color Cells in VBA

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
swjtx99
Asked:
swjtx99
  • 4
  • 4
1 Solution
 
nutschCommented:
Why not use conditional formatting?
0
 
swjtx99Author Commented:
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
 
nutschCommented:
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
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
swjtx99Author Commented:
!!!!!
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
 
nutschCommented:
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
 
swjtx99Author Commented:
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
 
nutschCommented:
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
 
swjtx99Author Commented:
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
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now