Sub Macro1()
Dim oTable As Table
Dim oCell As Range
Dim i As Long
    For Each oTable In ActiveDocument.Tables
        For i = 1 To oTable.Range.Cells.Count
            Select Case True
                Case InStr(1, oTable.Range.Cells(i).Range.Text, "Science") > 0
                    Set oCell = oTable.Range.Cells(i).Range
                    oCell.End = oCell.End - 1
                    oCell.Font.Color = wdColorGreen
                Case InStr(1, oTable.Range.Cells(i).Range.Text, "Health") > 0
                    Set oCell = oTable.Range.Cells(i).Range
                    oCell.End = oCell.End - 1
                    oCell.Font.Color = wdColorRed
                    'etc
            End Select
        Next i
    Next oTable
lbl_Exit:
    Set oTable = Nothing
    Set oCell = Nothing
    Exit Sub
End Sub