VBA - Coloring cells containing certain text strings

[jhol4]

Hi there

I was wondering if there was a way to highlight all cells on a worksheet containing a text string (lets say"A"). I want to be able to do this so I can select all applicable cells, and then color them a certain way, and then look for the next text string (lets say "B") and color it a different way.

I would like to be able to do this in one step rather than having to loop through all cells on the worksheet (until the last cell used). I know you can use something like Selection.SpecialCells which will highlight all cells containing constants, but I want to take it a step further and specify the constant that I want it to highlight.

Any help would be greatly appreciated.

 

[SydneyGeek]

Hi, just a couple of questions to clarify.
Cells "containing" a string -- is the string the full cell contents, like "Bananas", or a sub-string in that cell, eg "Ban" or "ana"?
How big is the used range? I'm not sure that you can use SpecialCells to select cell values, but you could use ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants,xlTextValues) to restrict to text only.
How many possible colors do you want to use? And how do you want to refer to them? Just that this will affect what you code for the InputBox that asks for a color.

Denis

 

[jhol4]

I would want the text strings to be exact. So that only cells containing "A" and nothing else would be colored. I was hoping to have the number of colors flexible so that the user could input another text string and color if they needed to. I would think that I would need at least 5 different colors / text strings. I havent got it set up with an input box, I simply have a range with a text string followed by a colored cell. The macro will obtain all of the text strings and colors prior to coloring all of the applicable cells.

The range is also variable, depending on the size of the sheet. Some may be 10 rows, others may be 5000 rows.

I guess what I'm looking for is a "Find All" type function.

Hope this makes sense....

 

[SIXTH SENSE]

Hi!
This color all A's in the used range with blue.
You can change the color of your choice and the criteria of your choice
<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> FindX()
Crit = "a"
<SPAN style="color:#00007F">Set</SPAN> add1 = UsedRange.Find(Crit, , , xlWhole)
<SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> add1 <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN>
    add1.Interior.ColorIndex = 5
    <SPAN style="color:#00007F">Set</SPAN> nxt = UsedRange.Find(Crit, add1, , xlWhole, , xlNext)
    <SPAN style="color:#00007F">While</SPAN> nxt.Address <> add1.Address
        nxt.Interior.ColorIndex = 5
        <SPAN style="color:#00007F">Set</SPAN> nxt = UsedRange.Find(Crit, nxt, , xlWhole, , xlNext)
    <SPAN style="color:#00007F">Wend</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[Tom Urtis]

Sub Test1()
Application.ScreenUpdating = False
Dim LR As Long, LC As Integer, ColorRange As Range, cell As Range
LR = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set ColorRange = Range(Cells(1, 1), Cells(LR, LC))
ColorRange.Interior.ColorIndex = 0
For Each cell In ColorRange.SpecialCells(2)
If cell.Value = "A" Then cell.Interior.ColorIndex = 5
Next cell
Application.ScreenUpdating = True
End Sub

 

[SydneyGeek]

This requires you to build a table called ChooseColors. The first column is the search string, the second is the colors -- pick from the available range.
The search area is on a second sheet -- start on this sheet.

Sub DoColors()
  Dim Picker As Variant
  Dim Colors As Variant
  Dim Rws As Long, j As Long
  Dim i As Integer
  Dim Sht As String
  Dim c As Range
  Dim FirstAddress
  
  Sht = ActiveSheet.Name
  'load search strings and colors into arrays
  Application.Goto Reference:="ChooseColors"
  ReDim Picker(1 To Selection.Rows.Count)
  ReDim Colors(1 To Selection.Rows.Count)
  For i = 1 To Selection.Rows.Count
    Picker(i) = ActiveCell.Value
    Colors(i) = ActiveCell.Offset(0, 1).Interior.ColorIndex
    ActiveCell.Offset(1, 0).Select
  Next i
  'search the test range, changing backgrounds as required
  Sheets(Sht).Activate
  For i = 1 To UBound(Picker)
    With Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
        Set c = .Find(Picker(i), LookIn:=xlValues)
        If Not c Is Nothing Then
            FirstAddress = c.Address
            Do
                c.Interior.ColorIndex = Colors(i)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
  Next i

End Sub

Took several seconds to replace 5 colors across 12 columns, 3000 rows. Total about 13000 cells formatted.

Denis

 

[Tom Urtis]

Another option, for multiple values wanting to be color-shaded:

Sub Test2()
Application.ScreenUpdating = False
Dim LR As Long, LC As Integer, ColorRange As Range, cell As Range
LR = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set ColorRange = Range(Cells(1, 1), Cells(LR, LC))
ColorRange.Interior.ColorIndex = 0
For Each cell In ColorRange.SpecialCells(2)
With cell.Interior
Select Case True
Case cell.Value = "A"
.ColorIndex = 5
Case cell.Value = "B"
.ColorIndex = 4
Case cell.Value = "C"
.ColorIndex = 3
End Select
End With
Next cell
Application.ScreenUpdating = True
End Sub

 

[SydneyGeek]

Slightly more compact version

Sub DoColors_v2()
  Dim Picker As Variant
  Dim Rws As Long, j As Long
  Dim i As Integer
  Dim c As Range
  Dim FirstAddress
  
  'load search strings and colors into Picker array
  With Range("ChooseColors")
    ReDim Picker(1 To .Rows.Count, 1 To 2)
    For i = 1 To .Rows.Count
      Picker(i, 1) = .Cells(i, 1).Value
      Picker(i, 2) = .Cells(i, 2).Interior.ColorIndex
    Next i
  End With
  'search the test range, changing backgrounds as required
  For i = 1 To UBound(Picker)
    With Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
        Set c = .Find(Picker(i, 1), LookIn:=xlValues)
        If Not c Is Nothing Then
            FirstAddress = c.Address
            Do
                c.Interior.ColorIndex = Picker(i, 2)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> FirstAddress
        End If
    End With
  Next i

End Sub

Denis

 

[Nisha_]

Hi, Is there a way to use this for a sub string?

Instead of searching for "A" in a cell that contains only "A", I want to search for "A" in a cell that contains "PHONE A FRIEND"

Thank you for any help

 

[Nisha_]

Hi, Is there a way to use this for a sub string?

Instead of searching for "A" in a cell that contains only "A", I want to search for "A" in a cell that contains "PHONE A FRIEND"

Thank you for any help