Looping in a table

[Alastair MacFarlane]

Dear All

I am trying to recurse through every cell in the the first
column of a table and obtain the cell contents. I have
used the following code (which works) but could be better:

Dim oRow As Row
Dim oCell As Cell
Dim sCellText As String
For Each oRow In ActiveDocument.Tables(1).Rows
sCellText = oRow.Cells(1).Range
sCellText = Left$(sCellText, Len(sCellText) - 2)
Debug.Print Trim(sCellText)
Next oRow

but I do not want all values returned but only those where
the cell or the font is NOT shaded or conversely where the
cell has no shading at all in the font or cell itself. It
is this part I am stuck with.

Can someone please help me?

Alastair MacFarlane
(very bad at Word VBA)

 

[Greg]

Alastair,

See if something like this helps:

Sub Test()
Dim oRow As Row
Dim oCell As Cell
Dim sCellText As String
For Each oRow In ActiveDocument.Tables(1).Rows
If oRow.Cells(1).Shading.BackgroundPatternColorIndex = wdAuto Then
sCellText = oRow.Cells(1).Range
sCellText = Left$(sCellText, Len(sCellText) - 2)
Debug.Print Trim(sCellText)
End If
Next
End Sub

 

[Alastair]

Thanks Greg for the quick response. I was obviously
looking deeper than that because I thought I would need to
check both the background colour and the font shaded
colour.

Sometimes it is the straightforward answer that is correct.

Alastair

 

[Helmut Weber]

Hi Alastair,

in case you'd like to look deeper:

Sub CellOrTextOrNoneOfThemShaded()
Dim oCll As Cell ' object Cell
Dim sCll As String ' string Cell
ActiveDocument.Tables(1).Columns(1).Select
' selection might be more often, not to say always,
' faster than ranges in tables
For Each oCll In Selection.Cells

If TextHasShading(oCll.Range) And CellHasShading(oCll.Range) Then
MsgBox Left$(sCll, Len(sCll) - 2)
End If
If TextHasShading(oCll.Range) Or CellHasShading(oCll.Range) Then
sCll = oCll.Range.Text
MsgBox Left$(sCll, Len(sCll) - 2)
End If
Next
End Sub
' ---
Public Function TextHasShading(oRng As Range) As Boolean
Dim lBckTxt As Long ' BackgroundPatternColor of text
Dim lFrgTxt As Long ' ForeroundPatternColor of text
Dim lTxtTxt As Long ' Texture of text

With oRng
lBckTxt = .Font.Shading.BackgroundPatternColor
lFrgTxt = .Font.Shading.ForegroundPatternColor
lTxtTxt = .Font.Shading.Texture
End With
If lBckTxt < 0 And lFrgTxt < 0 And lTxtTxt = 0 Then
TextHasShading = False
Else
TextHasShading = True
End If
End Function
' ---
Public Function CellHasShading(oRng As Range) As Boolean
Dim lBckCll As Long ' BackgroundPatternColor of Cell
Dim lFrgCll As Long ' ForeroundPatternColor of Cell
Dim lTxtCll As Long ' Texture of Cell

With oRng
lBckCll = .Shading.BackgroundPatternColor
lFrgCll = .Shading.ForegroundPatternColor
lTxtCll = .Shading.Texture
End With
If lBckCll < 0 And lFrgCll < 0 And lTxtCll = 0 Then
CellHasShading = False
Else
CellHasShading = True
End If
End Function

At least I enjoyed it.

Greetings from Bavaria, Germany

Helmut Weber, MVP
"red.sys" & chr(64) & "t-online.de"
Word XP, Win 98
http://word.mvps.org/

 

[Alastair MacFarlane]

Helmut,

Thanks for your input. It may take me quite a while to go through your code
and I am glad that I asked a question that got you-a-thinking. I don't think
it will be long before I ask another question.

Thanks...

Alastair