VBA to return capitalized words or phrases

[yits05]

Hello,

I have found a few answers on here that get me 75% of the way to what I need, but was hoping somebody could help me get it to 100%. I am looking for VBA script that will scan a single cell text string and return all words or phrases containing capital letters.

The rules I need are:
- IF the capitalized word is directly adjacent to another capitalized word(s), group them as a phrase.
- IF the capitalized word is on its own (i.e. not directly neighboring another capital word) then it is parsed on its own
- IF the word comes after a period (.), ignore.

I would also like each word or phrase to be placed in its own cell. So, for example, the result should look like this:

John Smith is joining ACME Solutions as its new CTO. He will replace Susan Johnson who is departing for ACME2

John Smith

ACME Solutions

CTO

Susan Johnson

ACME2

This is the VBA I found that gets me partially there:

Option Explicit
Function StrExtract(Str As String, Optional IgnoreFirst As Boolean = False) As String
Dim tmp As Variant, tmp2 As String, x As Long, y As Long

If IgnoreFirst Then x = 1
    tmp = Split(Str, " ")
For y = x To UBound(tmp)
    If tmp(y) = StrConv(tmp(y), vbProperCase) Then tmp2 = tmp2 & tmp(y) & ", "
Next
    If IgnoreFirst And tmp2 = vbNullString Then
        StrExtract = tmp(0)
    Else
        StrExtract = Replace(Left(tmp2, Len(tmp2) - 2), "?", "")
    End If
End Function

Many thanks!

 

[Eric W]

These kind of macros are really tricky. There are ALWAYS exceptions and quirks, and it's nearly impossible to allow for them all. Nevertheless, here's a stab at it:

Option Explicit

Function StrExtract(Str As String) As String
Dim tmp As Variant, wk As String, i As Long, cap As Boolean, cap2 As Boolean, GotPeriod As Boolean

    tmp = Split(WorksheetFunction.Trim(Str))
    
    GotPeriod = True
    wk = ""
    For i = 0 To UBound(tmp)
        cap = IIf(tmp(i) Like "[A-Z]*", True, False)
        cap2 = False
        If i < UBound(tmp) Then
            If tmp(i + 1) Like "[A-Z]*" Then cap2 = True
        End If
        If cap2 Then GotPeriod = False
        If cap And Not GotPeriod And tmp(i) <> "I" Then
            wk = wk & Replace(tmp(i), ".", "") & IIf(cap2 And InStr(tmp(i), ".") = 0, "|", " ")
        End If
        GotPeriod = IIf(Right(tmp(i), 1) = ".", True, False)
    Next i
    
    StrExtract = Replace(Replace(WorksheetFunction.Trim(wk), " ", ", "), "|", " ")

End Function

This gives the following results compared to your original function:

Book2
	A	B	C
1	John Smith is joining ACME Solutions as its new CTO. He will replace Susan Johnson who is departing for ACME2	John, Smith, Solutions, He, Susan, Johnson	John Smith, ACME Solutions, CTO, Susan Johnson, ACME2
2	I hate to work.	I
3	I always love ABC Deals. They work so hard for me.	I, Deals., , They	ABC Deals
4	Julia Roberts worked with Richard Gere.	Julia, Roberts, Richard, Gere.	Julia Roberts, Richard Gere
5	Nobody works as hard as I do.	Nobody, I
6	I hired Mr. Smith to work in the Accounting department.	I, Mr., Smith, Accounting	Mr, Accounting
Sheet6

Cell Formulas
Range	Formula
B1:B6	B1	=strextract1(A1)
C1:C6	C1	=strextract(A1)

It seems to be better, but it still has trouble with things like Mr. within the sentences.