asked on

Export data from word to Excel in special format....

Hello. I have data in a text file needs to be exported into Excel. Sounds simple and perhaps it is for the right person...The data is in a single column in the text file in a single column:

ALABAMA ADVANCED CRIMINAL JUSTICE ACADEMY
740 Mildred St
Montgomery, Alabama 36104
Phone: 334-240-4824
Fax: 334-240-4539

ALABAMA CANINE TRAINING CENTER
29 Rice Valley Rd Ne
Tuscaloosa, Alabama 35406
Phone: 205-391-2488
Fax: 205-391-2492

ALASKA DEPT OF SAFETY TRAINING ACADEMY
877 Sawmill Creek Rd
Sitka, Alaska 99835
Phone: 907-747-6611
Fax: 907-747-5606

ALASKA POLICE STANDARDS COUNCIL
450 Whittier St
Juneau, Alaska 99811
Phone: 907-465-4378
Fax: 907-465-3263

Here is what it would need to look like in Excel. The top line are headers for each column.:

Agency_name address address2 ph_num fax_num

Any ideas?

Patrick Matthews

Some clarifications requested:

1) Is this a text file, or a Word document? Your question is ambiguous on that point.

2) Will there ever be >2 address lines? E.g.:

ALASKA POLICE STANDARDS COUNCIL
450 Whittier St
Second Floor
Juneau, Alaska 99811
Phone: 907-465-4378
Fax: 907-465-3263

3) Is the phone number ALWAYS preceded by "Phone: "? The fax number by "Fax: "?

4) Why not separate the city, state, and ZIP? It can be done, and it will make your data much cleaner

ASKER CERTIFIED SOLUTION

SiddharthRout

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SiddharthRout

Cross over.

Sorry Patrick.

Sid

SiddharthRout

>>>>After you open the text file, simply run the macro Sample() and the data will be exported to Sheet1.

chancer74: I meant after you open the EXCEL file, simply run the macro Sample() and the data will be exported to Sheet1.

Sid

chancer74

ASKER

1) Is this a text file, or a Word document? Your question is ambiguous on that point.
Text
2) Will there ever be >2 address lines? E.g.:
No
ALASKA POLICE STANDARDS COUNCIL
450 Whittier St
Second Floor
Juneau, Alaska 99811
Phone: 907-465-4378
Fax: 907-465-3263

3) Is the phone number ALWAYS preceded by "Phone: "? The fax number by "Fax: "?
yes, yes
4) Why not separate the city, state, and ZIP? It can be done, and it will make your data much cleaner.
Wouldn't mind....

The file is a text file as I saved it as such from Word. Thx.

Patrick Matthews

I have not tested Sid's suggestions, so please be sure to check them out. In the meantime, this handles the data according to your original schema:

Sub GetAddrInfo()
    
    Dim BigArr As Variant
    Dim Results() As Variant
    Dim fso As Object
    Dim ts As Object
    Dim FilePath As Variant
    Dim Counter As Long
    Dim Field As Long
    Dim Test As String
    
    FilePath = Application.GetOpenFilename("Text files (*.txt), *.txt", , "Select file to process", , False)
    If FilePath = False Then
        MsgBox "No file selected; aborting", vbCritical, "No soup for you!"
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpenTextFile(FilePath)
    BigArr = ts.ReadAll
    ts.Close
    Set ts = Nothing
    Set fso = Nothing
    
    Do Until InStr(1, BigArr, " " & vbCrLf) = 0
        BigArr = Replace(BigArr, " " & vbCrLf, vbCrLf)
    Loop
    Do Until InStr(1, BigArr, vbCrLf & vbCrLf & vbCrLf) = 0
        BigArr = Replace(BigArr, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
    Loop
    BigArr = Split(BigArr, vbCrLf)
    
    ReDim Results(1 To 5, 1 To 1) As Variant
    Results(1, 1) = "Agency_name"
    Results(2, 1) = "address"
    Results(3, 1) = "address2"
    Results(4, 1) = "ph_num"
    Results(5, 1) = "fax_num"
    
    For Counter = 0 To UBound(BigArr)
        Test = BigArr(Counter)
        If LCase(Test) Like "phone:*" Then
            Test = Trim(Mid(Test, 7))
        ElseIf LCase(Test) Like "fax:*" Then
            Test = Trim(Mid(Test, 5))
        End If
        If Field = 0 And Test <> "" Then
            Field = 1
            ReDim Preserve Results(1 To 5, 1 To UBound(Results, 2) + 1) As Variant
        ElseIf Field > 0 And Test <> "" Then
            Field = Field + 1
        Else
            Field = 0
        End If
        If Field > 0 Then
            Results(Field, UBound(Results, 2)) = Test
        End If
    Next
    
    Workbooks.Add
    Cells(1, 1).Resize(UBound(Results, 2), UBound(Results, 1)).Value = Application.Transpose(Results)
    Columns.AutoFit
    
    MsgBox "Done"
    
End Sub

Open in new window

I will see about breaking up the second address line now.

Patrick

Patrick Matthews

OK, and this is splitting up address2 into city, state, and ZIP:

Sub GetAddrInfo()
    
    Dim BigArr As Variant
    Dim Results() As Variant
    Dim fso As Object
    Dim ts As Object
    Dim FilePath As Variant
    Dim Counter As Long
    Dim Field As Long
    Dim Test As String
    Dim CommaPos As Long
    Dim LastSpacePos As Long
    
    FilePath = Application.GetOpenFilename("Text files (*.txt), *.txt", , "Select file to process", , False)
    If FilePath = False Then
        MsgBox "No file selected; aborting", vbCritical, "No soup for you!"
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpenTextFile(FilePath)
    BigArr = ts.ReadAll
    ts.Close
    Set ts = Nothing
    Set fso = Nothing
    
    Do Until InStr(1, BigArr, " " & vbCrLf) = 0
        BigArr = Replace(BigArr, " " & vbCrLf, vbCrLf)
    Loop
    Do Until InStr(1, BigArr, vbCrLf & vbCrLf & vbCrLf) = 0
        BigArr = Replace(BigArr, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
    Loop
    BigArr = Split(BigArr, vbCrLf)
    
    ReDim Results(1 To 7, 1 To 1) As Variant
    Results(1, 1) = "Agency_name"
    Results(2, 1) = "address"
    Results(3, 1) = "city"
    Results(4, 1) = "state"
    Results(5, 1) = "zip"
    Results(6, 1) = "ph_num"
    Results(7, 1) = "fax_num"
    
    For Counter = 0 To UBound(BigArr)
        Test = BigArr(Counter)
        If LCase(Test) Like "phone:*" Then
            Test = Trim(Mid(Test, 7))
        ElseIf LCase(Test) Like "fax:*" Then
            Test = Trim(Mid(Test, 5))
        End If
        If Field = 0 And Test <> "" Then
            Field = 1
            ReDim Preserve Results(1 To 7, 1 To UBound(Results, 2) + 1) As Variant
        ElseIf Field > 0 And Test <> "" Then
            Field = Field + 1
        Else
            Field = 0
        End If
        Select Case Field
            Case 1, 2
                Results(Field, UBound(Results, 2)) = Test
            Case 3
                CommaPos = InStr(1, Test, ",")
                LastSpacePos = InStrRev(Test, " ")
                Results(3, UBound(Results, 2)) = Left(Test, CommaPos - 1)
                Results(4, UBound(Results, 2)) = Trim(Mid(Test, CommaPos + 1, LastSpacePos - CommaPos))
                Results(5, UBound(Results, 2)) = Mid(Test, LastSpacePos + 1)
            Case 4, 5
                Results(Field + 2, UBound(Results, 2)) = Test
            Case Else
                ' do nothing!
        End Select
    Next
    
    Workbooks.Add
    Cells(1, 1).Resize(UBound(Results, 2), UBound(Results, 1)).Value = Application.Transpose(Results)
    Columns.AutoFit
    
    MsgBox "Done"
    
End Sub

Open in new window

SiddharthRout

Nice one Patrick :)

chancer74: Did you get a chance to test what I posted?

Sid

chancer74

ASKER

Thanks for your help