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]

Thanks. I am grateful for everyone's help on this one. If it is of any help, although the speed of the code is always nice to have, the speed at which the code would function or do it's thing would be totally secondary in importance to just being able to get the key words underlined. If it were absolutely necessary, once the code was applied, the project could be left for a while as it did what was required.

 

[Rick Rothstein]

Thanks. I am grateful for everyone's help on this one. If it is of any help, although the speed of the code is always nice to have, the speed at which the code would function or do it's thing would be totally secondary in importance to just being able to get the key words underlined. If it were absolutely necessary, once the code was applied, the project could be left for a while as it did what was required.

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

 

[skyport]

Rick, you are certainly on the right track with this one. It functionally works and the part about having the separate page for adding words in brilliant and a great help.

I started testing it out and found that sometimes it seems to skip a key word here and there even though in the list.

Is it possible the concept of using the page with the list of words ,(which I really like), is case sensitive so a capped word in the list will only recognize that word in the record if it is capped as well?

 

[Rick Rothstein]

Rick, you are certainly on the right track with this one. It functionally works and the part about having the separate page for adding words in brilliant and a great help.

I started testing it out and found that sometimes it seems to skip a key word here and there even though in the list.

Is it possible the concept of using the page with the list of words ,(which I really like), is case sensitive so a capped word in the list will only recognize that word in the record if it is capped as well?

Theoretically, I took care of case sensitivity when I used vbTextCompare inside the InStr function calls. Can you give me a list of words and some text values in Column K's cells which demonstrate the problem so I can set it up here in order to debug the problem?

 

[skyport]

Thanks so much let me test it further and see if it smooths out and I will give you a report back later today. Thanks again for your help.

 

[Peter_SSs]

Rick's code would underline 'depression' in 'depressions', 'heat' in 'theatre' etc
That may be advantageous in the first example but I suspect disadvantageous in the second.

If you wanted to underline, say, plurals of your keywords then I think you would have to list them separately whatever code you use. A code might(?) possibly be able to identify 'depressions' as a plural of 'depression', but words like 'anxiety' give me exactly that when considering plurals.

Try the following code that should better match "words" rather than text strings.
About how many key words do you expect to have as there may be problems with my code if the list is large? Might be able to adapt though if that is the case.

Sub UnderlineKeyWords()
  Dim AllMatches As Object
  Dim itm As Variant
  Dim Cell As Range

  Const myCol As String = "K" '<- Column of interest
  
  Application.ScreenUpdating = False
  Columns(myCol).Font.Underline = False
  With CreateObject("VBScript.RegExp")
    .Global = True
    .IgnoreCase = True
    .Pattern = "\b(" & Join(Application.Transpose(Sheets("Words").Range("A1", Sheets("Words").Cells(Rows.Count, "A").End(xlUp)).Value), "|") & ")\b"
    For Each Cell In Range(myCol & 1, Range(myCol & Rows.Count).End(xlUp))
      Set AllMatches = .Execute(Cell.Text)
      For Each itm In AllMatches
        Cell.Characters(itm.firstIndex + 1, itm.Length).Font.Underline = True
      Next itm
    Next Cell
  End With
  Application.ScreenUpdating = True
End Sub

 

[skyport]

Greetings both Peter and Rick. Thanks again to you both for helping. The following are what I encountered after testing both concepts on different files with data as I would normally do: Peter raised a good point about the problem of partial words being underlined such as : if I needed the word mental underlined, Rick's program will underline that "mental" part of the word departmental. It would be nice if it could eliminate that type of issue if possible. Apart from that, Ricks program worked very well numerous times. Peter's program seemed to work on the first 7-8 cells of data in column K but did not underline at times in cells after that. Don't know why. In answer to Peter's question about how many words there would be, there could eventually be up to a one or two thousand key words. Hence the reason I thought the "word list" concept of Ricks seemed like a real good one and easy to add words to. In column K, there can be as many as a few thousand cells with data and key words in each one.

 

[Rick Rothstein]

Greetings both Peter and Rick. Thanks again to you both for helping. The following are what I encountered after testing both concepts on different files with data as I would normally do: Peter raised a good point about the problem of partial words being underlined such as : if I needed the word mental underlined, Rick's program will underline that "mental" part of the word departmental. It would be nice if it could eliminate that type of issue if possible. Apart from that, Ricks program worked very well numerous times. Peter's program seemed to work on the first 7-8 cells of data in column K but did not underline at times in cells after that. Don't know why. In answer to Peter's question about how many words there would be, there could eventually be up to a one or two thousand key words. Hence the reason I thought the "word list" concept of Ricks seemed like a real good one and easy to add words to. In column K, there can be as many as a few thousand cells with data and key words in each one.

Peter's code seemed to work fine for me. If you have specific cases where it didn't, posting your word list and the text in Column K that is being processed would be helpful so Peter could patch his code accordingly (if it actually needs it). You should strive for using Peter's code as it is noticeably faster than the solution I have posted below... 16 seconds versus 47 seconds for a word list consisting of four words processing 1000 cells in Column K containing a total of 48,161 characters... but I would expect the difference would become much larger with a longer word list and more text to process. Anyway, if you want to try it, here is my code (which consists of two procedure... the UnderlineCertainWordsInColumnK macro you call and the InStrExact function it calls repeatedly in order to do its work).

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 = InStrExact(1, Cell.Value, Words(x, 1))
      Do While Position
        Cell.Characters(Position, Len(Words(x, 1))).Font.Underline = True
        Position = InStrExact(Position + 1, Cell.Value, Words(x, 1))
      Loop
    Next
  Next
  Application.ScreenUpdating = True
End Sub

Function InStrExact(Start As Long, SourceText As String, WordToFind As Variant, _
                    Optional CaseSensitive As String = False, _
                    Optional AllowAccentedCharacters As Boolean = False) As Long
  Dim x As Long, Str1 As String, Str2 As String, Pattern As String
  Const UpperAccentsOnly As String = "ÇÉÑ"
  Const UpperAndLowerAccents As String = "ÇÉÑçéñ"
  If CaseSensitive Then
    Str1 = SourceText
    Str2 = WordToFind
    Pattern = "[!A-Za-z0-9]"
    If AllowAccentedCharacters Then Pattern = Replace(Pattern, "!", "!" & UpperAndLowerAccents)
  Else
    Str1 = UCase(SourceText)
    Str2 = UCase(WordToFind)
    Pattern = "[!A-Z0-9]"
    If AllowAccentedCharacters Then Pattern = Replace(Pattern, "!", "!" & UpperAccentsOnly)
  End If
  For x = Start To Len(Str1) - Len(Str2) + 1
    If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like _
                      Pattern & Str2 & Pattern Then
      InStrExact = x
      Exit Function
    End If
  Next
End Function

 

[Peter_SSs]

Peter's program seemed to work on the first 7-8 cells of data in column K but did not underline at times in cells after that.

1. Could you post some sample data from column K where the code failed somewhere soon after rows 7 or 8. Include data from those early rows as well as 2 or 3 that failed.

2. When the code failed, how many key words did you have in the 'Words' sheet?

3. If the answer to Q2 is 20 or less, could you post them too?

4. It may be obvious if you provide data per Q1 but do individual cells in column K have lots of text (ie many hundreds of characters)?

 

[skyport]

Peter, I will run it again and get you what you need per request above. Maybe the same thing will happen as did earlier with Rick's. Aftr the first run that seemed to lack some underlining, it did not happen again. I'll follow through on it asap. Did you say earlier your solution may limit the amount of key words that could be used? 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? As I mentioned above, there may eventually be a few thousand key words. Would that cause a problem?