View Single Post
 
Old 02-20-2020, 11:28 PM
macropod's Avatar
macropod macropod is offline Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 22,359
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

OK, try the following:
Code:
Sub TblHiLite()
Application.ScreenUpdating = False
Dim Hdr As Long, S As Long, W As Long, C As Long, R As Long, H As Long
Dim StrTitle As String, StrParms As String, StrRGB As String
'Abort if the cursor is not in a table
If Selection.Information(wdWithInTable) = False Then
  MsgBox "The selection is not in a table!", vbOKOnly, "TblHiLite"
  GoTo ErrExit
End If
'Get Parameters
On Error GoTo ErrExit
StrParms = Split(Selection.Tables(1).Range.Previous.Paragraphs.Last.Range.Text, vbCr)(0)
C = Trim(Split(Split(StrParms, "=")(1), ",")(0))
Hdr = Trim(Split(Split(StrParms, "=")(2), ",")(0))
StrRGB = Trim(Split(StrParms, "=")(3))
S = RGB(Split(StrRGB, ",")(0), Split(StrRGB, ",")(1), Split(StrRGB, ",")(2))
On Error GoTo 0
W = RGB(255, 255, 255)
'process the table
With Selection.Tables(1)
  If C > .Columns.Count Then
    MsgBox "There is no column " & C & " in the table!", vbOKOnly, "TblHiLite"
    End
  End If
  If Hdr > .Rows.Count Then
    MsgBox "There is no row " & Hdr & " in the table!", vbOKOnly, "TblHiLite"
    End
  End If
  StrTitle = Split(.Cell(1 + Hdr, C).Range.Text, vbCr)(0)
  .Rows(1 + Hdr).Shading.BackgroundPatternColor = W: H = W
  For R = 2 + Hdr To .Rows.Count
    If Split(.Cell(R, C).Range.Text, vbCr)(0) <> StrTitle Then
      If H = W Then H = S Else H = W
      StrTitle = Split(.Cell(R, C).Range.Text, vbCr)(0)
    End If
    .Rows(R).Shading.BackgroundPatternColor = H
  Next
End With
Application.ScreenUpdating = True
End
ErrExit:
MsgBox "Invalid Parameter", vbExclamation
End Sub
Note that your parameters can specify any +ve value for the number of header rows. As coded, the sub simply aborts if the parameters are invalid.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote