#1
|
||||
|
||||
Macro to highlight alternating sections of a table
I have a table of results for a collection of experiments. Each experiment has a title and may be run multiple times with different criteria. When I sort the table by the title, I like to highlight every other set of results with a light blue background. This helps be focus on the results for each experiment.
I did this manually once. But now I have added some new experiments that sort between existing experiments. Unless I redo the entire list, I will have two consecutive sets with the same highlighting (blue or none). I would like to write a macro to redo the highlighting every time I add a new experiment, but my skills with Word VBA is not good enough. Can someone give me the initial outline of a macro that will loop through each line (row) of a table, examine the title field, and change the highlighting whenever the title changes? Here's a rough outline of what I think the macro needs to do. The code in parens is what I don't know how to do. Code:
Sub TableHiLite() 'Not sure if it needs parameters Dim HiLite as boolean HiLite = True Dim Row as Integer Dim NumRows as Integer NumRows = (number of rows in the table) Dim TitleNext as String Dim TitlePrev as String For Row = 2 to NumRows TitleNext = (title text in this row) If TitleNext <> TitlePrev then HiLite = Not HiLite If HiLite then (set the highlight for this row to light blue) Else (set the highlight for this row to light none) Next Row End Sub PS: Ooops. I just realized that this should have gone into the VBA section. Maybe someone can move it. Sorry. |
#2
|
||||
|
||||
Perhaps:
Code:
Sub TblHiLite() Application.ScreenUpdating = False Dim r As Long, h As Long, StrTitle As String With Selection.Tables(1) StrTitle = Split(.Cell(2, 1).Range.Text, vbCr)(0) .Rows(2).Shading.BackgroundPatternColorIndex = 0 h = 0 For r = 3 To .Rows.Count If Split(.Cell(r, 1).Range.Text, vbCr)(0) <> StrTitle Then If h = 0 Then h = 3 Else h = 0 StrTitle = Split(.Cell(r, 1).Range.Text, vbCr)(0) End If .Rows(r).Shading.BackgroundPatternColorIndex = h Next End With Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
Thanks, Paul. That works great.
Where can I find a list of the color codes? |
#4
|
||||
|
||||
They're listed under the wdColorIndex enumeration in the VBA Help file. You could use BackgroundPatternColor instead of BackgroundPatternColorIndex, and specify the RGB values.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
||||
|
||||
Quote:
Now, is there a way to pass parameters to the macro? My search suggests that there is not. I have to have the macro ask for parameters using InputBox or a Form. A couple of parameters that would make this macro more general are:
|
#6
|
||||
|
||||
I tweaked the code a bit. Here is a working macro. The target text must be in column 1 and the first row is assumed to be a header.
Code:
Sub TblHiLite() Const MyName As String = "TblHiLite" 'Const Blue As Long = 15849926 'Light blue (198,217,241) Const Blue As Long = 15853019 'Light blue (219,229,241) Const White As Long = 16777215 'No highlighting 'Abort if the cursor is not in a table If Selection.Information(wdWithInTable) <> True Then MsgBox "The cursor is not in a table", vbOKOnly, MyName Exit Sub End If Application.ScreenUpdating = False Dim Row As Long 'Row number (loop index) Dim HiLiteColor As Long 'The ????? Dim TgtTextNew As String 'The target text string Dim TgtTextOld As String 'The previous target text string HiLiteColor = Blue 'Initialize color With Selection.Tables(1) 'Focus the selection on the table For Row = 2 To .Rows.Count 'Loop through all row but the header TgtTextNew = Split(.Cell(Row, 1).Range.Text, vbCr)(0) 'Get next text string If TgtTextNew <> TgtTextOld Then 'If it's a new section TgtTextOld = TgtTextNew 'Save the text 'Switch colors If HiLiteColor = White Then HiLiteColor = Blue Else HiLiteColor = White End If .Rows(Row).Shading.BackgroundPatternColor = HiLiteColor 'Apply highlighting Next Row End With Application.ScreenUpdating = True End Sub |
#7
|
||||
|
||||
Quote:
Sub Macro(Parameter1 As Long, Parameter2 As String, Optional Parameter3 As Boolean) where: • 'Parameter' 1-3 are the parameter names (more than3 are allowed); • Long, String & Boolean are the parameter types; and • Optional indicates that the parameter need not be supplied (these must only come after all the mandatory parameters). Thus, you might use something along the lines of: Code:
Sub TblHiLite(ColNum As Long, Hdr As Boolean, Shading 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" Exit Sub End If Application.ScreenUpdating = False Dim h As Long, n As Long, r As Long, s As Long, StrTitle As String Const w As Long = RGB(255, 255, 255) 'Determine the start row, according to whether there's a header If Hdr = True Then n = 3 Else n = 2 End If 'Get the applicable colour constant Select Case Trim(LCase(Shading)) Case "pale blue": s = RGB(198, 217, 241) Case "pale green": s = RGB(153, 255, 153) Case "pale yellow": s = RGB(255, 255, 153) Case "pink": s = RGB(255, 153, 153) Case Else: s = w End Select 'process the table With Selection.Tables(1) StrTitle = Split(.Cell(n - 1, ColNum).Range.Text, vbCr)(0) .Rows(2).Shading.BackgroundPatternColorIndex = 0 h = w For r = n To .Rows.Count If Split(.Cell(r, ColNum).Range.Text, vbCr)(0) <> StrTitle Then If h = w Then h = s Else h = w StrTitle = Split(.Cell(r, ColNum).Range.Text, vbCr)(0) End If .Rows(r).Shading.BackgroundPatternColor = h Next End With Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#8
|
||||
|
||||
Quote:
But I don't know how to pass them to the Sub. I call my sub using a keyboard shortcut (Alt+Ctrl+Shift+h). Do I have to edit that assignment every time I want to change the parameter values to be passed? Does that make sense? |
#9
|
||||
|
||||
In that case, you might code the sub along the lines of:
Code:
Sub TblHiLite() Application.ScreenUpdating = False Dim c As Long, h As Long, n As Long, r As Long, s As Long, w As Long, StrTitle As String, Hdr As Boolean w = RGB(255, 255, 255) '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 c = CLng(InputBox("Starting Column?", "TblHiLite")) If LCase(InputBox("Table has a header row?", "TblHiLite")) = "yes" Then Hdr = True Else Hdr = False Shading = CLng(InputBox("Colour for Shading? Select # from:" & vbCr & _ "0: none" & vbCr & _ "1: pale blue" & vbCr & _ "2: pale green" & vbCr & _ "3: pale yellow" & vbCr & _ "4: pink", "TblHiLite")) On Error GoTo 0 'Determine the start row, according to whether there's a header If Hdr = True Then n = 3 Else n = 2 End If 'Get the applicable colour constant Select Case s Case 1: s = RGB(198, 217, 241) Case 2: s = RGB(153, 255, 153) Case 3: s = RGB(255, 255, 153) Case 4: s = RGB(255, 153, 153) Case Else: s = w End Select 'process the table With Selection.Tables(1) If c > .Columns.Count Then MsgBox "There is no column " & c & " in the table!", vbOKOnly, "TblHiLite" GoTo ErrExit End If StrTitle = Split(.Cell(n - 1, c).Range.Text, vbCr)(0) .Rows(2).Shading.BackgroundPatternColorIndex = 0 h = w For r = n 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 ErrExit: Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#10
|
||||
|
||||
OK, so then an InputBox or Form is the way to pass parameters, right?
Thanks |
#11
|
||||
|
||||
Unless you want to go to the trouble of creating a userform, I'd stick with inputboxes for something as simple as this.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#12
|
||||
|
||||
Thanks to Paul's help, I now have a macro that does just what I need. I did not add the InputBox code as I don't need it right now. I'll add that later if I do.
Here's the code in case it might be useful for anyone else: Code:
'=========================================================================== ' Table Highlight Macro ' Written for Jigsaw Puzzle Log. ' Highlight alternate sections in light blue. ' Based on code from Macropod on MSOfficeForums. ' Syntax: TblHiLite 'Assigned to Alt+Ctrl+Shift+h ' To Do ' Add test for HumHdrs > number of rows. ' Add test for Column > number of columns. ' Add InputBoxes for column number, highlight colors, header row. ' Change Log '=========================================================================== Sub TblHiLite() Const MyName As String = "TblHiLite" 'Abort if the cursor is not in a table If Selection.Information(wdWithInTable) <> True Then MsgBox "The cursor is not in a table", vbOKOnly, MyName Exit Sub End If Dim HiLite1 As Long, HiLite2 As Long 'The two alternating highlight colors Dim Blue As Long: Blue = RGB(219, 229, 241) 'Light blue Dim White As Long: White = RGB(255, 255, 255) 'White = no highlighting HiLite1 = White HiLite2 = Blue Application.ScreenUpdating = False Dim Row As Long 'Row number (loop index) Dim Column As Long 'The column number Dim NumHdrs As Long 'The number of header rows Dim HiLiteColor As Long 'The integer RGB value Dim TgtTextNew As String 'The target text string Dim TgtTextOld As String 'The previous target text string HiLiteColor = HiLite2 'Initialize the highlight color Column = 1 'Initialize the column number NumHdrs = 1 'Initialize the number of header rows TgtTextOld = "!@#$%^&*()=+{}[]<>" 'In case first text string is blank With Selection.Tables(1) 'Focus the selection on the table For Row = NumHdrs + 1 To .Rows.Count 'Loop through all row but the header TgtTextNew = Split(.Cell(Row, Column).Range.Text, vbCr)(0) 'Get next text string If TgtTextNew <> TgtTextOld Then 'If it's a new section TgtTextOld = TgtTextNew 'Save the text 'Switch colors If HiLiteColor = HiLite1 Then 'If it's #1 HiLiteColor = HiLite2 'Switch to #2 Else 'Else, it's #2 HiLiteColor = HiLite1 'So switch to #1 End If End If .Rows(Row).Shading.BackgroundPatternColor = HiLiteColor 'Apply highlighting Next Row End With Application.ScreenUpdating = True End Sub |
#13
|
||||
|
||||
PS: Can anyone suggest a better way to initialize TgtTextOld than:
Code:
TgtTextOld = "!@#$%^&*()=+{}[]<>" |
#14
|
||||
|
||||
Have a look at how my code initialises StrTitle.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#15
|
||||
|
||||
Perfect, will do. I also notice that you have code for checking that the column number is in bounds, so I'll add that, too.
Do you have a way for the macro to read the line (paragraph) just before the table? If so, I could put the parameters there. |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Macro to highlight a list of words | bakerkr | Word VBA | 4 | 10-19-2017 02:23 PM |
Word 2010 VBA Print Macro - Specified Sections | Benbon | Word VBA | 3 | 03-30-2017 02:31 PM |
Macro Question: Need help making a macro to highlight the first word in every sentence | LadyAna | Word | 1 | 12-06-2014 10:39 PM |
Macro to highlight words | bertietheblue | Word VBA | 9 | 07-01-2013 12:39 PM |
find - reading highlight - highlight all / highlight doesn't stick when saved | bobk544 | Word | 3 | 04-15-2009 03:31 PM |