Convert Word to Excel

[juris]

I have 188 pages of contact information in a word document that I am trying to get into a preformated Excel file. Here is what the Word doc looks like (188 pages worth):

Steven Brown, Member
Office of Policy & Planning, Port Authority of New York & New Jersey, The
233 Park Avenue South 11th Floor
New York, NY 10003
Phone: (212)-435-4411 Fax:
E-Mail: sbrown@panynj.gov
Region: Northeast

J. Russell Bruner, Member
Senior Vice President, Line Management, Maersk, Inc.
Giralda Farms, Madison Avenue P.O. Box 880
Madison, NJ 07940-0880
Phone: (973)-514-5485 Fax: (973)-514-5675
E-Mail: namlintop@maersk.com
Region: Northeast

Domenic T. Bua, Member
Vice President, Gordon, Bua & Reed, Inc., Div. of TranSystems
34 Salem Street
Reading, MA 01960
Phone: (781)-944-7110 Fax: (781)-944-6708
E-Mail: dtbua@transystems.com
Region: Northeast

I need this to fill into an Excel sheet that has columns for each specific type of data (First name, Middle, Last Name, Title, Company, etc. etc.)

I have to do this once a month, so I need something fairly automated. Otherwise, I am looking at 12 hours or more of pure cut/paste. Any help will be greatly appreciated.

Thanks
Greg

 

[Trag]

Hey Juris,

Welcome to the board.

I am by far no expert in Excel but I've combined & edited other people codes to make a rough work around for you.

Maybe someone on the board here can make it even better but at least it's a start. This code will only work properly if the word "Region" is on your last line of the contact information.

Sub transferdata()
'Copy address information into A1 Sheet1 before running macro

'This next step will delete all blank rows in column A
'Thanks to DRJ for this part.
Application.ScreenUpdating=False

LastRow = Range("A65536").End(xlUp).Row

For b = LastRow To 1 Step -1

If Range("A" & b).Value = cond Then
Range("A" & b).Delete
Else
End If

Next b

'Thanks to TryingToLearn for posting this code.
'This code transposes your pasted info into Sheet2 of your workbook.

Dim firstaddress
Dim x, y, fr, tr, rw As Integer
Dim c

With Sheets("sheet1").Range("a1:" & Range("a65536").End(xlUp).Address)
Set c = .Find("Region", LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
fr = c.Row
y = 0
For x = fr To 1 Step -1
Sheets("sheet2").Cells(1, x) = c.Offset(-y, 0)
On Error Resume Next
Error.Clear
y = y + 1
Next x
rw = 1
Do
rw = rw + 1
Set c = .FindNext(c)
tr = c.Row
y = 0
For x = fr + 1 To tr Step 1
Sheets("sheet2").Cells(rw, y + 1) = c.Offset(fr - tr + y + 1, 0)
On Error Resume Next
Error.Clear
y = y + 1
Next x
fr = tr
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Sheets("Sheet2").Select
Application.ScreenUpdating=True
End Sub


http://www.mrexcel.com/board2/viewtopic.php?t=83366

http://www.mrexcel.com/board2/viewtopic.php?t=75864


~Trag

 

[Domenic]

Here's another possible solution provided that your contact information is layed out in a consistent format, such as every contact occupying the same number of lines and each contact separated by two paragraph marks.

Basically, you convert the Word file into a comma-delimited text file by using Word's find and replace feature (of course, you'll loose any formatting that you may have). Then you import it into Excel as a comma-delimited file.

So you can try something like:

find ^p^p and replace all with xxx
find ^p and replace all with a comma
find xxx and replace all with ^p
delete extra comma at the end of the document
save as a text file
import into Excel as a comma-delimited file

It's not pretty, but it should do the trick. Hope this helps!