loop through tables in word and change color of cells

Hello forum,
I would like to have suggestions on how to change color in tables using VBA. The word file has many tables but all have the same structure, only the contents change. I need a macro which changes the background color of the cells according to the contents. So for example, if the cell contains the text "I" then I want that cell colored in blue, if insted it contains "V" then it should be red and so on for 8 different classes. The following is the macro I modified (the original one was developed by someone else) but when I run it nothing happen, and I don't understand where I'm wrong.
Thank you for any help!
Daniel

Code:

---

Sub colora()
Dim MyTable As Table
Dim MyRow As Row
Dim MyCell As Cell
For Each MyTable In ActiveDocument.Tables
For Each MyRow In MyTable.Rows
  For Each MyCell In MyRow.Cells
    If MyCell.Range.Text = "I" Then
      MyCell.Shading.BackgroundPatternColor = wdColorBlue
    ElseIf MyCell.Range.Text = "V" Then
      MyCell.Shading.BackgroundPatternColor = wdColorRed
    End If
Next MyCell
Next MyRow
Next MyTable
Set MyCell = Nothing
Set MyRow = Nothing
Set MyTable = Nothing
End Sub

---

Please note the crossposting below with the same question but differently formulated
https://groups.google.com/g/microsof.../c/YLWdSId_14k

Code:

---

Sub colora()
Dim MyTable As Table
Dim MyRow As Row
Dim MyCell As Cell
  For Each MyTable In ActiveDocument.Tables
    For Each MyCell In MyTable.Range.Cells
      If InStr(MyCell.Range.Text, "I") > 0 Then
        MyCell.Shading.BackgroundPatternColor = wdColorBlue
      ElseIf InStr(MyCell.Range.Text, "V") > 0 Then
        MyCell.Shading.BackgroundPatternColor = wdColorRed
      End If
    Next MyCell
  Next MyTable
  Set MyCell = Nothing: Set MyTable = Nothing
End Sub

---

Thank you Greg for you quick reply!
It works but not as expected. If in the cell I have for example "IV" (or IV), the cell is colored in blue, but this should not be the case. I want the cell blue if and only if, the string is "I".
Thank you for any additional comments,
best wishes from Italy

Try:

Code:

---

Sub Colora()
Application.ScreenUpdating = False
Dim MyTable As Table, MyCell As Cell, BkGrnd As Long
For Each MyTable In ActiveDocument.Tables
  For Each MyCell In MyTable.Range.Cells
    Select Case Split(MyCell.Range.Text, vbCr)(0)
      Case "I":  BkGrnd = wdColorBlue
      Case "V":  BkGrnd = wdColorRed
      Case Else: BkGrnd = wdColorAutomatic
    End Select
    MyCell.Shading.BackgroundPatternColor = BkGrnd
  Next MyCell
Next MyTable
Set MyCell = Nothing: Set MyTable = Nothing
Application.ScreenUpdating = True
End Sub

---

You haven't explained the situation that well. What if the cell contains "I don't understand" or "V for victory" do you still want the cell color, or only if the full content is "I" or "V"

Code:

---

Sub Colora()
Dim MyTable As Table, MyCell As Cell
  For Each MyTable In ActiveDocument.Tables
    For Each MyCell In MyTable.Range.Cells
      With MyCell
      Select Case Left(.Range.Text, Len(.Range.Text) - 2)
        Case "I":  .Shading.BackgroundPatternColor = wdColorBlue
        Case "V":  .Shading.BackgroundPatternColor = wdColorRed
        Case "VI": .Shading.BackgroundPatternColor = wdColorBrightGreen
        Case Else: .Shading.BackgroundPatternColor = wdColorAutomatic
      End Select
      End With
    Next MyCell
  Next MyTable
  Set MyCell = Nothing: Set MyTable = Nothing
lbl_Exit:
  Exit Sub
End Sub

---

Dear Paul and Greg,
thank you both. The solution by Paul places the color on each cell containing "I" but also if the cell contains somenthing like "Items", and I don't want this. The cell should be colored only if it contains "I".
The last solution by Greg provides the expected result. However, I wonder why the macro is so slow, it takes 2-3 seconds to process a table with 60 cells. Is that normal?
Thank you again,
best regards
Daniel

Quote:

---

Originally Posted by Spitale

The solution by Paul places the color on each cell containing "I" but also if the cell contains somenthing like "Items"

---

No, it does not. The code finds cells whose first (only) paragraph contains only I or V - changing them as per your specifications - plus resetting the background colour of any cells that contain anything other than only I or V. Greg's does essentially the same thing, except that it allows for the possibility there might be multiple paragraphs in the cell.

My code should work slightly quicker than Greg's, because it turns off screen updating while running. A Find/Replace would likely be quicker still:

Code:

---

Sub Demo()Application.ScreenUpdating = False
Dim Rng As Range, BkGrnd As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[IV]>"
    .Replacement.Text = ""
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    If .Information(wdWithInTable) = True Then
      Set Rng = .Cells(1).Range
      With Rng
        .End = .End - 1
        Select Case .Text
          Case "I":  BkGrnd = wdColorBlue
          Case "V":  BkGrnd = wdColorRed
        End Select
        .Cells(1).Shading.BackgroundPatternColor = BkGrnd
      End With
    End If
    .Collapse wdCollapseEnd
  Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

---

Thank you Paul, now the application is a bit faster even though less clear to understand for a newbie like me. When I approached the problem seemed quite easy to solve but soon has become difficult. Thank you also for the explanation, I did not think about all the possible options.
Best wishes
Daniel

The "less clear to understand" probably relates to the Find expression, which is a wildcard Find for words consisting of the single character I or V. For more details, see: Finding and replacing characters using wildcards (wordmvp.com)

Dear Paul and Greg,
I would like to modify a bit the code to accomodate more than two cases. However, once I added the cases, the code still colors only the I and V as in the original solution. What I'm doing wrong?
Thank you
Daniel

Code:

---

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, BkGrnd As Long
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[IV]>"
    .Replacement.Text = ""
    .Format = False
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = True
  End With
  Do While .Find.Execute
    If .Information(wdWithInTable) = True Then
      Set Rng = .Cells(1).Range
      With Rng
        .End = .End - 1
        Select Case .Text
          Case "I":  BkGrnd = RGB(0, 112, 192)
          Case "I-II":  BkGrnd = RGB(155, 194, 230)
          Case "II":  BkGrnd = RGB(0, 176, 80)
          Case "II-III":  BkGrnd = RGB(146, 208, 80)
          Case "III":  BkGrnd = RGB(255, 255, 0)
          Case "III-IV":  BkGrnd = RGB(255, 230, 153)
          Case "IV":  BkGrnd = RGB(255, 192, 0)
          Case "IV-V":  BkGrnd = RGB(244, 176, 132)
          Case "V":  BkGrnd = RGB(255, 0, 0)
          Case Else: BkGrnd = wdColorAutomatic
        End Select
        .Cells(1).Shading.BackgroundPatternColor = BkGrnd
      End With
    End If
    .Collapse wdCollapseEnd
  Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

---

As I said in post #9:

Quote:

---

Originally Posted by macropod

The "less clear to understand" probably relates to the Find expression, which is a wildcard Find for words consisting of the single character I or V. For more details, see: Finding and replacing characters using wildcards (wordmvp.com)

---

(emphasis added)


Accordingly. you need to use a Find expression that finds all the combinations you're interested in. You can do that by changing:
.Text = "<[IV]>"
to:
.Text = "<[IV\-]{1,}>"

Hello Paul, thank you for the response. I changed that part as suggested but I encountered and error, it says "the text in the Find cell contains an invalid expression". I'm using word 2016. I read wildcards documentation without finding the answer. Could you help me once more? Thank you
Daniel

That suggests you're using a system with non-English regional settings. Change:
.Text = "<[IV\-]{1,}>"
to:
.Text = "<[IV\-]{1;}>"

Now it works perfectly, and it is also relatively fast! Thank you so much!
Daniel