Importing addresses from a Word Chart

[lukedalie]

Hi everyone.

I'm looking to transfer an address book from a three-column word chart to a table in excel. In the current Word address book, each address is in cells in envelope format. So it's....

Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902

...in each cell in a table that is three columns accross, 40 pages long.

I need to import each address so that it shows up in rows like this...

Chief Clancy Wiggum 443 Lane Road Candyland, WY 55902

...so that I can make a table. How do I import from this format without having to re-organize every entry?

[mehmetcik]

First export the word file as a plain text file.

Open the resultant file using excel.

When I did this I got a continuous list of addresses:-


Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902
Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902
Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902
Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902
Chief Clancy Wiggum
443 Lane Road
Candyland, WY
55902

Excl can easily convert this into the format that you are after.

If you concentrate on the export.

I will write a macro to do the conversion for you.

Sub Macro1()
'
' Macro1 Macro
'

LR = Range("A65536").End(xlUp).Row + 1
MyPath = ActiveWorkbook.Path
temp = InStrRev(ActiveWorkbook.Name, ".")
MyName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
MyName2 = MyName & ".xlsm"

    ActiveWorkbook.SaveAs Filename:=MyPath & "\" & MyName2, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        
        
    Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    Range("B2:B" & LR).FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),1,"""")"
    Range("C2:C" & LR).FormulaR1C1 = "=IF(AND(ROW()>2,R[-1]C[-1]<>1),R[-1]C & ""|"" &RC[-2],RC[-2])"
    Range("D2:D" & LR).FormulaR1C1 = "=IF(RC[-2]=1,RC[-1],"""")"
    
    Range("A1:D" & LR).Value = Range("A1:D" & LR).Value

    ActiveWorkbook.Worksheets(MyName).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Chief Clancy Wiggum").Sort.SortFields.Add Key:= _
        Range("D2:D" & LR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets(MyName).Sort
        .SetRange Range("A2:D" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

SR = Range("D65536").End(xlUp).Row + 1

Rows(SR & ":" & LR).Delete
Columns("A:C").Delete
    Range("A1:A" & SR - 1).Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    Columns("A:D").Select
    Selection.Columns.AutoFit

    ActiveWorkbook.Worksheets(MyName).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Chief Clancy Wiggum").Sort.SortFields.Add Key:= _
        Range("A2:A" & LR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets(MyName).Sort
        .SetRange Range("A2:D" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Range("A1").Select
End Sub

[lukedalie]

The export worked great, and thank you in advance!