Extract Specific Text From Middle of a String

[zljordan]

Hi All,

I have a list of companies copied over from a .pdf file. I am attempting to extract individual text strings into a specific column based on Company Name, Ticker Symbol, and CUSIP. Similar to what text to columns would do, but recognizing where the company name ends, and the ticker symbol, etc. begin. Please see the attached file for more information.

Thank you!
11575

[Ago]

Parse the text from right to left.

Meaning:
Grab the cellvalue and delimit it with space to an array.
Place the last value of the array in column F.
Next in E
Then D.
And the rest in C (remember to add a space between them again)

[snb]

Sub M_snb()
For Each cl In Sheet1.Columns(1).SpecialCells(2)
y = InStr(StrReverse(Left(cl, Len(cl) - 12)), " ") - 1
If cl.Row > 1 Then cl.Parse "[" & String(Len(cl) - y - 13, "x") & "] [" & String(y, "x") & "] [xxxxxxxxx] [x]", cl.Offset(, 10)
Next
End Sub

or


Sub M_snb()
sn = Sheet1.UsedRange.Columns(1)
ReDim sp(UBound(sn), 4)

For j = 2 To UBound(sn)
st = Split(sn(j, 1))
sp(j, 3) = st(UBound(st))
sp(j, 2) = st(UBound(st) - 1)
sp(j, 1) = st(UBound(st) - 2)
sp(j, 0) = Replace(sn(j, 1), " " & sp(j, 1) & " " & sp(j, 2) & " " & sp(j, 3), "")
Next

Cells(1, 3).Resize(UBound(sp) + 1, UBound(sp, 2) + 1) = sp
End Sub

[p45cal]

Select the one-column wide range of cells to be processed, not including the header, then run this:
Sub spliit2()
Dim myResults()
Set SourceRng = Selection
'Set SourceRng = Range("$A$2:$A$284") 'alternative to above.
Set DestnRng = SourceRng.Offset(, 2).Resize(, 4)
DestnRng.Columns(3).NumberFormat = "@"
zz = SourceRng.Value
ReDim myResults(1 To UBound(zz), 1 To 4)
rw = 1
For Each itm In zz
xx = Split(itm)
Z = UBound(xx)
myResults(rw, 4) = xx(Z)
myResults(rw, 3) = xx(Z - 1)
myResults(rw, 2) = xx(Z - 2)
CoNm = ""
For i = 0 To Z - 3
CoNm = Join(Array(CoNm, xx(i)))
Next i
myResults(rw, 1) = Application.Trim(CoNm)
rw = rw + 1
Next itm
DestnRng.Value = myResults
End Sub

[zljordan]

Thank you p45cal! This works perfectly!