VBA question - selecting a start point

[skyport]

I got help here on this forum a while back for a program that is at the bottom of this posting. The program is great and automatically underlined certain words in every cell in column K. The key 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. I am hoping for an answer from this forum.

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

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

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 each cell 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 current program I am using - posted below will underlined any keyword in the entire cell. However, for the work I am now doing, 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 would underline the key words ( in the example above, the search for words to underline would start with the word Diagnosis and then search and underline any key words through the rest of the paragraph).

My question is: If there is 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 that period followed by two blank spaces, which once again only occurs one time in each cell.

It is important to keep the program in tact to continue the basic functions it is already doing so well and I am hoping someone can offer the solution to the small addition outlined above.

Would appreciate any help that can be offered.


Below is the original program I am using:


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

 

[Jerry Sullivan]

Here is a modified version that I hope will accomplish what you describe.

Note that in your example paragraph, the date is followed by a period and only one blank space character.
I presume this is a typo-please clarify if I misunderstood the setup.

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, StartIndex As Long

 Const DataSht As String = "Sheet2" '<- Name of sheet where underlining is done
 Const myCol As String = "K" '<- Column of interest on DataSht
 Const Delimiter As String = ".  " '<-Characters that mark end of heading
 

 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)
      StartIndex = InStr(s, Delimiter)
      If StartIndex > 0 Then
         StartIndex = StartIndex + Len(Delimiter) + 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
               If (tmp(j) >= StartIndex) Then
                  .Characters(tmp(j), tmp(j + 1)).Font.Underline = True
               End If
            Next j
         End With
      End If
   Next i
 End With
 
 Application.ScreenUpdating = True
End Sub

 

[Jerry Sullivan]

I noticed an error. Please correct this line:

StartIndex = StartIndex + Len(Delimiter) + 1

...to read:

StartIndex = StartIndex + Len(Delimiter)

 

[skyport]

Jerry, Thanks for helping. Yes you are correct. The lack of the 2 spaces in example is a typo

 

[skyport]

Jerry,

At the first testing, it seems to work perfect like a charm. I will give it the full challenge with some more trials tomorrow and give you feedback ASAP however, from what I am seeing upfront, it looks like it will pass all the challenges. Thanks again for your help. I will respond tomorrow sometime.

 

[skyport]

Jerry,

FINAL FEEDBACK - After using your program on various work projects, it works perfectly, has resolved the problem totally and never failed. Thanks so much again for your help.

 

[Rick Rothstein]

Jerry,

FINAL FEEDBACK - After using your program on various work projects, it works perfectly, has resolved the problem totally and never failed. Thanks so much again for your help.

Here is another macro you might want to try. I have not time tested it (so I may be wrong) , but I believe it will execute quite quickly. If you decide to test it, I would be interested in knowing how it compared speed-wise to Jerry's code.

Sub UnderlineKeyWords_V3()
  Dim R As Long, KW As Long, MaxKeyWordsPerLine As Long, WordCount As Long
  Dim KeyWords As Variant, Data As Variant, Start As Variant, Underline As Variant
  Const DataSht As String = "Sheet1" '<- Name of sheet where underlining is done
  Const Col As String = "K"          '<- Column of interest on DataSht
  Const Delimiter As String = ".  "  '<-Characters that mark end of heading
  KeyWords = Sheets("Words").Range("A1", _
             Sheets("Words").Cells(Rows.Count, "A").End(xlUp))
  Data = Sheets(DataSht).Range(Cells(1, Col), _
         Sheets(DataSht).Cells(Rows.Count, Col).End(xlUp))
  ReDim Start(1 To UBound(Data))
  For R = 1 To UBound(Data)
    Start(R) = InStr(Data(R, 1), Delimiter) + 2
    WordCount = Len(Mid(Data(R, 1), Start(R))) - _
                Len(Replace(Mid(Data(R, 1), Start(R)), " ", ""))
    If WordCount > MaxKeyWordsPerLine Then MaxKeyWordsPerLine = WordCount
  Next
  ReDim Underline(1 To UBound(Data), 1 To MaxKeyWordsPerLine, 1 To 2)
  For R = 1 To UBound(Data)
    For KW = 1 To UBound(KeyWords)
      Do
        Start(R) = InStr(Start(R) + 1, Data(R, 1), KeyWords(KW, 1), vbTextCompare)
        If Start(R) = 0 Then Exit Do
        Underline(R, KW, 1) = Start(R)
        Underline(R, KW, 2) = Len(KeyWords(KW, 1))
      Loop
    Next
  Next
  For R = 1 To UBound(Data)
    For KW = 1 To MaxKeyWordsPerLine
      If Underline(R, KW, 1) Then
        Sheets(DataSht).Cells(R, "K").Characters(Underline( _
            R, KW, 1), Underline(R, KW, 2)).Font.Underline = True
      End If
    Next
  Next
End Sub

 

[skyport]

Hi Rick, Good to hear from you again. You might recognize the basic program as a concept that both you and Peter in Australia worked out for me. I was able to use both versions then.

I will be delighted to test this new addition and let you know torward the end of the week which will give me time to see how it dances with different partners so to speak. Thanks again.

 

[skyport]

Rick,

Got some early feedback for you. I'm getting an error that debug indicates is in the following lines:

Data = Sheets(DataSht).Range(Cells(1, Col), _
Sheets(DataSht).Cells(Rows.Count, Col).End(xlUp))

 

[Rick Rothstein]

Rick,

Got some early feedback for you. I'm getting an error that debug indicates is in the following lines:

Data = Sheets(DataSht).Range(Cells(1, Col), _
Sheets(DataSht).Cells(Rows.Count, Col).End(xlUp))

What is the error number and error message?