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]

Rick, Will run your latest version and let you know. The first version worked very quickly on 100 cells in column K using 230 keywords on the list page

 

[Rick Rothstein]

Rick, Will run your latest version and let you know. The first version worked very quickly on 100 cells in column K using 230 keywords on the list page

My new code will probably be noticeably slower as it has a lot more to do to make sure the word is a "stand-alone" word and not part of some other text. I know it will be quite a bit slower as your word list grows into the thousands.

 

[Peter_SSs]

Did you say earlier your solution may limit the amount of key words that could be used?

It *might*. Alternative code below should work with any number of key words.

Also, how would I add new key words or is it somehow pulling from the same "Words" page list I used with Rick's solution?

Yes it is. Just add all your key words into column A of a sheet called 'Words' in the same workbook as the data. At the moment my code expects no blank cells within the data in column A. If there is, the code will take quite a while to run and everything in column K will get underlined. I could build in an extra check for blanks if required.

Anyway, give this version a try too.
I have set an arbitrary limit of 1000 keywords that could be found in a single cell in column K, hence Dim tmp(1 To 2000) As Long
I hope you don't have anything like that in a single cell!!
That number could probably be brought down a fair bit but I don't think it should matter either way.

The only thing I'm getting a bit nervous about is that looking back I see you are using Excel 2000 - that is very old - so I hope all this works in that version.

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 = "Data"    '<- 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

 

[skyport]

Peter and Rick

I sure appreciate you both sticking with me on this. Rick's second verson works very well. As stated, it takes several seconds to complete the function however, it does the job perfectly well and time factor is not a big problem. It would be nice to see if I can get Peter's version 2 to work as well. I am getting run-time error 9 subscript out of range. When I choose debug, it selects the following line in the program - With Sheets(DataSht)

 

[Peter_SSs]

It would be nice to see if I can get Peter's version 2 to work as well. I am getting run-time error 9 subscript out of range. When I choose debug, it selects the following line in the program - With Sheets(DataSht)

I thought that the comment in the code would make you realise that you had to edit this line

Const DataSht As String = "Data"    '<- Name of sheet where underlining is done

 

[skyport]

Whoops, sorry Peter. That one went right over my head. Will change it accordingly

 

[skyport]

OK, Both programs totally do the job with great efficiency. As indicated earlier, Peter's code functions faster however, there is one distinct advantage for some of the work I am doing for using Rick's methodology. Here is an example:

Consider the following line: Apportionment: Apportionment to causation is most likely not an issue.

In the word list, I have only "Apportionment:" (with the colon) and not Apportionment (without a colon). What this allows for in Rick's version is the one and only exception case where when the key word is followed by a colon it should be underlined and if not with a colon, no underline.

EXAMPLE: Apportionment: Apportionment to causation is most likely not an issue.

In Rick''s version, it conveniently underlines the word only when combined with the colon (as written in the words list) but not the other one without a colon thereby avoiding the following:

EXAMPLE: EXAMPLE: Apportionment: Apportionment to causation is most likely not an issue.

This unique situation only occurs with 2 of the keywords , and where I entered them onto the word list with a colon.

Because Peter's program is much faster, if there was a way to do the above, that code would be the perfect utopia. In the event it cannot be done, Rick's program would function for some of the applications and I could switch back and forth between the 2 concepts if need be.

Once again, I thank you both for the great job done.

 

[Peter_SSs]

See if this change accommodates that requirement

For i = 1 To UBound(KeyWords, 1)
  <del>KeyWords(i, 1) = "\b" & KeyWords(i, 1) & "\b"</del>
  KeyWords(i, 1) = "\b" & KeyWords(i, 1) & "(?= |\b|$)"
Next i

 

[skyport]

BULLSEYE ...... Peter, You nailed it down real good with that last one. It is now perfect and works very fast as well. Does it all. Thank a million and fifty.

I also want to say once again thanks to Rick as well and his well functioning program was a lifesaver for me over the past couple of days while we waited for this wonderful final version that you did.

God Bless to you both and this Excel Forum has the best with your solutions, knowledge and brains for this sort of thing.

 

[Peter_SSs]

BULLSEYE ...... Peter, You nailed it down real good with that last one. It is now perfect and works very fast as well. Does it all. Thank a million and fifty.

Good news, it has been an interesting exercise - which is the reason many of us help here.

I also want to say once again thanks to Rick as well and his well functioning program ..

I'll second that. As usual, I have gained more knowledge & coding ideas by reading his suggestions/code.

God Bless to you both and this Excel Forum has the best with your solutions, knowledge and brains for this sort of thing.

Thank you, it is always nice to have appreciative forum members.