Consulting

Results 1 to 9 of 9

Thread: Color table cell based on string

  1. #1
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    5
    Location

    Color table cell based on string

    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.

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    "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
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    5
    Location
    Greg,

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

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    I must have missed the last line when copying/pasting. Add:

    End Sub

    as the last line.
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    5
    Location
    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

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

  7. #7
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    5
    Location
    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

  8. #8
    VBAX Newbie
    Joined
    Oct 2020
    Posts
    5
    Location
    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.

  9. #9
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,218
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •