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