FANTASTIC-Thanks for your help!!!
1 more thing if you don't mind.
I get list set up in label format in word that I need to put in excel. Is it
possible to take it and put it in excel. This code won't work because I can't
paste it into excel in 1 row because the records are 3 across 10 down like
example below:

Mr. Joe Roach Steve Cummings
Chris Gedrich
Chairman €“ Board of Selectmen Deputy Fire Chief Project
Executive
Town of Sharon Sharon Fire Department Suffolk
Construction
Town Hall 92 South Main Street
65 Allerton Street
90 South Main Street Sharon, MA 02067
Boston, MA 02119
Sharon, MA 02067




"Tom Ogilvy" wrote:

the code depends on there being a single blank row between each address.

If you have multiple blank rows between each address, then

Sub ParseData()
Dim r As Range, r1 As Range
Dim r2 As Range, rw As Long
Dim cell As Range, c As Range
Dim rng As Range
Dim i As Long, j As Long
Dim s As String, s1 As String
Dim s2 As String, s3 As String
Dim ipos1 As Long, ipos2 As Long
rw = 2
Set rng = Columns(1).SpecialCells(xlBlanks)
For Each cell In rng.Areas
Set r = cell(cell.count).Offset(1, 0)
Set r1 = r.End(xlDown)
Set r2 = Range(r, r1)
j = 0
If r2.Rows.Count 7 Then Exit Sub
For Each c In r2
j = j + 1
Cells(rw, 3 + j) = c.Value
Next
Cells(rw, 3 + 1) = Trim(Replace _
(Cells(rw, 3 + 1), "TO:", ""))
s = Cells(rw, 3 + j)
ipos1 = InStr(1, s, ",", vbTextCompare)
ipos2 = InStrRev(s, " ", -1, vbTextCompare)
s1 = Trim(Left(s, ipos1 - 1))
s2 = Trim(Mid(s, ipos1 + 1, ipos2 - ipos1))
s3 = Mid(s, ipos2 + 1, 255)
Cells(rw, 3 + j) = s1
Cells(rw, 3 + j + 1) = s2
Cells(rw, 3 + j + 2) = s3
rw = rw + 1
Next cell
End Sub

--
Regards,
Tom Ogilvy


"gwbdirect" wrote:

Hi Tom,
Works to a point. When they gave me the list they left spaces between each
address.
TO: Medical Director
Saint Marys Hospital
1216 Second Street SW
Rochester, MN 55902


TO: Medical Director
Mayo Clinic
4500 San Pablo Road
Jacksonville, FL 32224

can I eliminate the space in the code or do I need to do it in word first.
If so how do I take out the space in word.

"Tom Ogilvy" wrote:

Why not just copy and paste it into Excel, then you can parse it out in Excel
- that would simplify your problem.

Make sure row1 is empty
(First address should start in A2)

Sub ParseData()
Dim r As Range, r1 As Range
Dim r2 As Range, rw As Long
Dim cell As Range, c As Range
Dim rng As Range
Dim i As Long, j As Long
Dim s As String, s1 As String
Dim s2 As String, s3 As String
Dim ipos1 As Long, ipos2 As Long
rw = 2
Set rng = Columns(1).SpecialCells(xlBlanks)
For Each cell In rng
Set r = cell.Offset(1, 0)
Set r1 = r.End(xlDown)
Set r2 = Range(r, r1)
j = 0
If r2.Rows.Count 7 Then Exit Sub
For Each c In r2
j = j + 1
Cells(rw, 3 + j) = c.Value
Next
Cells(rw, 3 + 1) = Trim(Replace _
(Cells(rw, 3 + 1), "TO:", ""))
s = Cells(rw, 3 + j)
ipos1 = InStr(1, s, ",", vbTextCompare)
ipos2 = InStrRev(s, " ", -1, vbTextCompare)
s1 = Trim(Left(s, ipos1 - 1))
s2 = Trim(Mid(s, ipos1 + 1, ipos2 - ipos1))
s3 = Mid(s, ipos2 + 1, 255)
Cells(rw, 3 + j) = s1
Cells(rw, 3 + j + 1) = s2
Cells(rw, 3 + j + 2) = s3
rw = rw + 1
Next cell
End Sub


Worked for me with the data you show.

--
regards,
Tom Ogilvy


"gwbdirect" wrote:

How can I take a list example below and import it into excel in column
format? Is this possible?
TO: Medical Director
Mayo Cancer Center-Albert Lea
404 West Fountain Street
Albert Lea, MN 56007

TO: Medical Director
Albert Lea Eye Clinic
1206 West Front Street
Albert Lea, MN 56007

NAME COMPANY CITY STATE ZIP