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

 

[skyport]

says: Runtime-error 1004
application defined or object defined error

Additional note: I did note that the sheet where underlining should be done must be sheet 2. I made that change to see if it would eliminate the error however, that change returned the following:

runtime error 9
subscript out of range

 

[Rick Rothstein]

says: Runtime-error 1004
application defined or object defined error

Additional note: I did note that the sheet where underlining should be done must be sheet 2. I made that change to see if it would eliminate the error however, that change returned the following:

runtime error 9
subscript out of range

Just so you know, I test the code before I posted it and it appeared to work fine, so the problem has to be a difference in the setup between my test case and your actual layout. On the data sheet, the column is still K and the delimiter is still a dot followed by two spaces, correct? What row is the first data item on in Column K? Also, what row is the first name on in the word list? And what is the name of the sheet the word list is on?

 

[skyport]

Yes, - the column is still K and the delimiter is still a dot followed by two spaces.
ROW 1 for both - What row is the first data item on in Column K and the first name on in the word list.
words - is the name of the sheet the word list is on?

 

[Rick Rothstein]

Yes, - the column is still K and the delimiter is still a dot followed by two spaces.
ROW 1 for both - What row is the first data item on in Column K and the first name on in the word list.
words - is the name of the sheet the word list is on?

That setup seems to be what I used in my tests. I think the only way to figure out why it is not working for you is to see your workbook first-hand so I can debug the code live. Can you send it to me? If yes, my email address is...

rick DOT news AT verizon DOT net

Please include this thread's title in your response so I can more easily find my way back to this thread.

 

[skyport]

Hi Rick,

I sent the sample worksheet over to you day before yesterday at the email you gave, let me know you got it.

 

[Rick Rothstein]

Hi Rick,

I sent the sample worksheet over to you day before yesterday at the email you gave, let me know you got it.

Yes, I got it... and I think I found the problem. See if the following macro works for you..

Sub UnderlineKeyWords_V3()
  Dim R As Long, KW As Long, X As Long, Position 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 = "Sheet2" '<- 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)
      Position = Start(R)
      X = 0
      Do
        Position = InStr(Position + 1, Data(R, 1), KeyWords(KW, 1), vbTextCompare)
        If Position = 0 Then Exit Do
        X = X + 1
        Underline(R, X, 1) = Position
        Underline(R, X, 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

got some feedback. It is instantaneous however, it only underlined some of the words some of the times from the list on the "words column". No idea why but I will test it again in a day or so.

 

[Rick Rothstein]

Hi Rick

got some feedback. It is instantaneous however, it only underlined some of the words some of the times from the list on the "words column". No idea why but I will test it again in a day or so.

If it still doesn't underline all words, send the workbook to me (with the data shown before the macro was run) and tell me maybe 3 or 4 of the words you thought should be underlined but weren't so that I can try and trace down the problem. Remember, I want the data before the macro was run so I can see the original setup.

 

[skyport]

Does not give any indication of error or message. It simply does not underline all of the words from the list. Other than that, the program goes through the process without any indication of anything wrong.

 

[skyport]

Rick,

Did you ever receive this that you were asking for?