Solved

Color Cells in VBA

Posted on 2014-01-28
8
414 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
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

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

 

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

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

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

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Excel if formula 2 19
Excel 2007 Macro to Change Column Formatting 3 33
VBA or Script to identify files which are duplicate in a folder 6 32
Excel VBA 30 38
Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

839 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