automatically underline certain key words in all cells in a column

[skyport]

Was hoping there is a chance this can actually be done with some sort of VBA -automatically underline certain key words in all cells in a column

 

[skyport]

My hopes in posting the previous final comments were to let others know the value of your suggestions and results and hopefully everyone becomes happier. Perhaps down the road paths will cross with a new challenge or maybe one day I'll make it out there to the land down under with the rising sun I have 3 favorite things that I believe are Australian: A ****atiel, zebra finches and an authentic Australian slouch military hat with the left side turned up with the Australian rising sun on it.

Thanks again, and for any others reading, Peter's final solution was PERFECT.

 

[Peter_SSs]

.. maybe one day I'll make it out there to the land down under ..

If you do, don't be afraid to make contact with some Aussie forum members.
I note that two of your favourites are birds. I also have quite an interest in birds and my favourite, by far, is the male Regent Bower Bird. Absolutely stunning & luckily reasonably often come to the bird bath just outside our window.

 

[skyport]

Thanks, I would most certainly do so.

My goodness, what an astounding bird that Regent Bower is. Just looked at it on the net. See amazing wing span in first link below and then the others are of what must be a relative bird - The Flame Bower bird. Amazing creations.

https://ppcdn.500px.org/16170077/19b8e0c0bb9c92ec47fbf18a5164b79914ae13d9/5.jpg

https://encrypted-tbn0.gstatic.com/...VIl3u3o16zTCNyETL8J5Nq56cXetq75HJqjSBTmD-HtWA

http://www.surfbirds.com/Trip%20Reports/woodspng0807/2flamebowerbirdkeith.jpg

 

[Peter_SSs]

My goodness, what an astounding bird that Regent Bower is. Just looked at it on the net. See amazing wing span in first link below and then the others are of what must be a relative bird - The Flame Bower bird.

Yes, that's one of the great sights to see the bird in flight - great picture. The Flame Bower Bird is likely related, but not Australian. It is native to Papua New Guinea, just north of Australia.

 

[skyport]

Sure seems that the whole region down there produces some of the best in birds. A real paradise for bird lovers. I love the ****atiel because it almost is human in some of its actions. Mine will wake me up every morning by doing a little dance on my head.

 

[skyport]

Hi Peter, Hope all is well for you and the Bower Birds there in Australia

You were kind enough to share the fantastic program, a copy of which is at the bottom of this message, and the program has worked fantastically. The program automatically underlined certain words in every cell in column K. You may recall that the words to be underlined were contained in a column titled "words".


A situation has come up in the procedure I am using the program for, which calls for a very small adjustment if possible.


Here is the situation: Consider the following paragraph in a given cell in column K:


Primary Treating Physician's Progress Report, Sam F. David, D.C., 9/18/2014. Page 1 of report is missing. Diagnosis: 1. Sub-acute traumatic moderate repetitive cervical spine sprain/strain radiating to both arms.


The above example is a typical beginning of a paragraph that would exist in each cell in column K. The first date that appears in the first or second lines always represents the last portion of the title or heading for the paragraph, which is always followed by a period and two blank spaces following the period. It is the only time in every cell that there will be a period followed by two blank spaces. The program you made for me would underlined any keyword in the entire paragraph. However, everything in the title or heading (prior to the period and two blank spaces ) must never have a word underlined. Only the rest of the paragraph after the period and two blank spaces. Is there any way ( Using the period and following two blank spaces as a reference point) to have the program underline only keywords after the occurrence of the period followed by two blank spaces, which once again only occurs one time in each cell.


Would appreciate any help you can offer


Below is the original program you wrote:


Sub UnderlineKeyWords_v2()
Dim AllMatches As Object
Dim itm As Variant, KeyWords As Variant, Keyword As Variant, Data As Variant
Dim tmp(1 To 2000) As Long
Dim DataRng As Range
Dim s As String
Dim i As Long, j As Long, k As Long


Const DataSht As String = "Sheet2" '<- Name of sheet where underlining is done
Const myCol As String = "K" '<- Column of interest on DataSht

Application.ScreenUpdating = False
With Sheets("Words")
KeyWords = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
End With
For i = 1 To UBound(KeyWords, 1)
KeyWords(i, 1) = "\b" & KeyWords(i, 1) & "(?= |\b|$)"
Next i
With Sheets(DataSht)
.Columns(myCol).Font.Underline = False
Set DataRng = .Range(myCol & 1, .Range(myCol & .Rows.Count).End(xlUp))
End With
Data = DataRng.Value
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
For i = 1 To UBound(Data, 1)
Erase tmp
s = Data(i, 1)
k = -1
For Each Keyword In KeyWords
.Pattern = Keyword
Set AllMatches = .Execute(s)
For Each itm In AllMatches
k = k + 2
tmp(k) = itm.firstIndex + 1
tmp(k + 1) = itm.Length
Next itm
Next Keyword
With DataRng.Cells(i)
For j = 1 To k Step 2
.Characters(tmp(j), tmp(j + 1)).Font.Underline = True
Next j
End With
Next i
End With
Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Is there any way ( Using the period and following two blank spaces as a reference point) to have the program underline only keywords after the occurrence of the period followed by two blank spaces, which once again only occurs one time in each cell.

Sorry for the slow reply. I have not been on the forum lately and won't be around much for a few months.
Try adding these four blue lines into the existing code where indicated.

  Dim i As Long, j As Long, k As Long
  Dim StartPos As Long

Erase tmp
s = Data(i, 1)
StartPos = InStr(1, s & ".  ", ".  ")
k = -1

For Each itm In AllMatches
  If itm.firstindex > StartPos Then
    k = k + 2
    tmp(k) = itm.firstindex + 1
    tmp(k + 1) = itm.Length
  End If
Next itm

 

[mlien]

Okay, it turned out not to be as complicated as I first thought it might be... give this a try. Add a worksheet to your workbook and make its name "Words" (without the quotes) and then list all the words you want underlined in Column A starting at Row 1 (you can add words to, or subtract words from, this list as needed, but you will have to run the macro below every time afterwards.

Sub UnderlineCertainWordsInColumnK()
  Dim X As Long, Position As Long, Cell As Range, Words As Variant
  Application.ScreenUpdating = False
  Words = Sheets("Words").Range("A1", Sheets("Words").Cells(Rows.Count, "A").End(xlUp))
  Range("K:K").Font.Underline = False
  For Each Cell In Intersect(Columns("K"), ActiveSheet.UsedRange)
    For X = 1 To UBound(Words)
      Position = InStr(1, Cell.Value, Words(X, 1), vbTextCompare)
      Do While Position
        Cell.Characters(Position, Len(Words(X, 1))).Font.Underline = True
        Position = InStr(Position + 1, Cell.Value, Words(X, 1), vbTextCompare)
      Loop
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Hi,

I have tried to make this marcro work but cant get my head around why its not functioning.

I have created a tab and named it Word, on the first row and cell I have input the words I want underlined. The code is pasted in a module. I ran the macro in my excel but nothing happens. What am I doing wrong here. Can you give me some pointers? thanks!

 

[Rick Rothstein]

Hi,

I have tried to make this marcro work but cant get my head around why its not functioning.

I have created a tab and named it Word,

If you look at my code carefully, you will see it is expecting the worksheet to be named "Words" with an "s" at the end, not "Word" as you have indicated above that you named it.

 

[mlien]

Hi Rick,

Sorry that was a typo, the name of my datasheet is indeed Words.

Is there another version to your code, I think I saw this on the following pages of this thread.

I run the marco and nothing happens, do I need to highlight the cells that I want the macro to check?

You can check these photos and see if you can make any sense as to why its not working for me.

https://gyazo.com/4b33c35530810008d6dffb239db3a7d8
https://gyazo.com/7aa2807ed390c5a42bf3a8954c166e2d
https://gyazo.com/cd4a8b689447dfd5f8bb2d3dd6c7f662