Solved

Color Cells in VBA

Posted on 2014-01-28
8
416 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Online Training Solution

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action. Forget about retraining and skyrocket knowledge retention rates.

 

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

Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

Question has a verified solution.

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

This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
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…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

752 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