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
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
