Color table cell based on string

[lshawver]

First time using Macros -- super powerful, not so simple.

I need a program that will:

Search all tables in a word doc
If a cell contains certain text (string, not numeric), it shades that cell a certain color, then removes the text


Help greatly appreciated!!! I'm working on behalf of a colleague who is tasked with manually shading HUNDREDS of cells. I feel her pain and want to help.

[gmaxey]

"Some text" and "Some color" is not very specific:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim oTbl As Table
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "some text"
While .Execute
Set oTbl = Nothing
On Error Resume Next
Set oTbl = oRng.Tables(1)
If Not oTbl Is Nothing Then
oRng.Cells(1).Shading.BackgroundPatternColor = wdColorBrightGreen
oRng.Collapse wdCollapseEnd
End If
Wend
End With
lbl_Exit:
Exit Sub

[lshawver]

Greg,

Thank you for your response. I have received a compile error: Expected End Sub

[gmaxey]

I must have missed the last line when copying/pasting. Add:

End Sub

as the last line.

[lshawver]

Nice, no compile error. But it's not shading when I run it. Could it be that the cells in question are populated via a mail merge with drop down menu options in Excel? I'm looking to shade cells in this way:
"Rarely" = red
"Sometimes" = orange
"Often" = yellow
"Consistently" = green

[gmaxey]

Well the code I sent is looking for "some text" To look for four different strings and using four different colors, you would need a loop:


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim oTbl As Table
Dim arrTerm() As String
Dim arrCI(3) As Long
Dim lngIndex As Long
arrTerm = Split("Rarely,Sometimes,Often,Consistently", ",")
arrCI(0) = wdColorRed: arrCI(1) = wdColorOrange: arrCI(2) = wdColorYellow: arrCI(3) = wdColorGreen
For lngIndex = 0 To UBound(arrTerm)
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = arrTerm(lngIndex)
While .Execute
Set oTbl = Nothing
On Error Resume Next
Set oTbl = oRng.Tables(1)
If Not oTbl Is Nothing Then
oRng.Cells(1).Shading.BackgroundPatternColor = arrCI(lngIndex)
oRng.Collapse wdCollapseEnd
End If
Wend
End With
Next lngIndex
lbl_Exit:
Exit Sub
End Sub

[lshawver]

Greg, thank you for your reply. I wish I could write this myself, but it's far beyond my skills and experience. I still can't get it to work. I have had some luck with the code below, but it only works for numeric values (how do I change this to identify strings instead? - exchanging 1,2,3,4 with "Rarely", "Sometimes", "Often", "Consistently") and it only works for the selected table (how to I get it to work for ALL tables in the document?).


'code by Linda Wu MSFT
Sub colourSelectedTable()
Dim c As Word.Cell
If Selection.Information(wdWithInTable) Then
For Each c In Selection.Tables(1).Range.Cells
If IsNumeric(Left(c.Range.Text, Len(c.Range.Text) - 1)) Then
If Val(c.Range.Text) = 1 Then
c.Shading.BackgroundPatternColor = wdColorRed
ElseIf Val(c.Range.Text) = 2 Then
c.Shading.BackgroundPatternColor = wdColorOrange
ElseIf Val(c.Range.Text) = 3 Then
c.Shading.BackgroundPatternColor = wdColorYellow
ElseIf Val(c.Range.Text) = 4 Then
c.Shading.BackgroundPatternColor = wdColorGreen
End If
Else ' set cells without those words to White
c.Shading.BackgroundPatternColor = wdColorWhite
End If
Next
End If
End Sub

[lshawver]

Aha, the code works beautifully. It wasn't working for me at first because the table is contained within a shape. Any way to search within shapes for tables? If not, I'll just reformat my template.

[gmaxey]

Search the TextFrameStory ranges.


Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRng As Range
Dim oTbl As Table
Dim arrTerm() As String
Dim arrCI(3) As Long
Dim lngIndex As Long
arrTerm = Split("Rarely,Sometimes,Often,Consistently", ",")
arrCI(0) = wdColorRed: arrCI(1) = wdColorOrange: arrCI(2) = wdColorYellow: arrCI(3) = wdColorGreen
For lngIndex = 0 To UBound(arrTerm)
Set oRng = ActiveDocument.StoryRanges(wdTextFrameStory)
Do
With oRng.Find
.Text = arrTerm(lngIndex)
While .Execute
Set oTbl = Nothing
On Error Resume Next
Set oTbl = oRng.Tables(1)
If Not oTbl Is Nothing Then
oRng.Cells(1).Shading.BackgroundPatternColor = arrCI(lngIndex)
oRng.Collapse wdCollapseEnd
End If
Wend
End With
Set oRng = oRng.NextStoryRange
Loop Until oRng Is Nothing
Next lngIndex
lbl_Exit:
Exit Sub
End Sub