Populate an Excel file from a txt file

[Jaredhott]

Good afternoon,

I get an email in this format based on how many fields a person fills out in a questionnaire

First_Name: jim
Last_Name: bond
Address: 820 west
City: mytown
State: al
Zip: 11111
Email: myname@gmail.com
Height: 6'3"
Weight: 210
Date_of_Birth: 3/31/95
Married: no
Father_Name: Roy Rogers
Father_Cell_Phone: 111111
Mother_Name: May Rogers
Mothers_Cell_Phone: 18175

i want to populate this info into an excel file so that if a person fills out a questionnaire I can populate the rows that they fill out into an excel document with the field names at the top and the field values down the column like this:

[TABLE="width: 217"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]First_Name[/TD]
[TD]Last_Name[/TD]
[TD]Address[/TD]
[/TR]
[TR]
[TD]jim[/TD]
[TD]bond[/TD]
[TD]820 west[/TD]
[/TR]
[TR]
[TD]bill[/TD]
[TD]player[/TD]
[TD]555 main[/TD]
[/TR]
[TR]
[TD]steve[/TD]
[TD]taylor[/TD]
[TD]44 1st [/TD]
[/TR]
</tbody>[/TABLE]

it would be great to figure out how to automate it from the email but for right now i can copy the email into a txt file manually and import it to excel. i just want the import to match the fields and insert the value going down the column. let me know if you guys have an idea how to do something like this.

 

[igold]

Hi,

This should work for you, just make sure your data looks like the examples in Post #s 1, 2, 3, and not Post #8, meaning that there are no gaps in sets of data. Also the only other caveat is that the first line of each set of data must begin with "First_Name".

I tested this and it worked with this text:

First_Name: jim
Last_Name: bond
Address: 820 west
City: mytown
State: al
Zip: 11111
Mothers_Cell_Phone: 18175
First_Name: Joe
Last_Name: Namath
Address: 500 East
City: Yourtown
State: NY
Zip: 11023
Email: myname@live.com
Height: 6'3"
Weight:
Date_of_Birth: 3/31/95
Married: no
Father_Name: Roy Rogers
Father_Cell_Phone: 111111
Mother_Name: May Rogers
Mothers_Cell_Phone: 18175
First_Name: James
Last_Name: Garner
Address: 1110 Main Street
City: North
State: AL
Zip: 11116
Email: myemail
Phone: 402-800-0618
Cell_Phone: 402-111-1111
Height: 5'9"
Weight: 185
Date_of_Birth: 1-19-1990
Married: no
Father_Name: Richard
Father_Email: myemail
Father_Cell_Phone: 111-111-1114
Father_Occupation: Radio
Mother_Name: S
Mothers_Email: myemail
Mothers_Cell_Phone: 111-111-1113
Mother_Occupation: Teacher
Would_like_to_visit: Yes
High_School: Myschool
School_Phone: 411-111-1111
Graduation_Date: 2012
High_School_GPA: 1.0
First_Name: John
Last_Name: Name
Address: 513 Main
City: east
State: SD
Zip: 11111
Email: myemail
Cell_Phone: 111-111-1111
Height: 6'1 1/2
Weight: 210
Date_of_Birth: 3/4/91
Married: no
Father_Name: Gary
Father_Email: myemail
Father_Cell_Phone: 111-111-1111
High_School: Baltic
School_Phone: 111-1111
Graduation_Date: 2017
High_School_GPA: 3.04
Class_Rank: 16
College_Interest: Computer Networking
Football_Info:
Football_High_School_Coach: Jim Name
Offensive_Position: fullback/tight-end
Defensive_Position: DT/MLB
Enrollment_Year: 2018
bench: 225
squat: 350
vertical: 22 inch
forty_yard_Dash_Time: Not sure
Other_Colleges_Interested: NDL
twitter_handle: Don't have twitter
Link_to_facebook_account: Don't have facebook

Sub TextFlie2()


    Dim row_number As Single
    Dim LineFromFile As Variant
    Dim col_number As Single, i As Integer, LC As Long
    Dim FilePath As String, Newline As String
    Dim rngField As Range
    
    Application.ScreenUpdating = False
    FilePath = "E:\Excel VBA\Test22.txt"
    Close #1
    Open FilePath For Input As #1
    Newline = "First_Name"
    row_number = 0
    col_number = -1
    Range("a1").Select


    Do Until EOF(1)
        Line Input #1, LineFromFile
        If Left(LineFromFile, 10) = Newline Then GoTo NewRecord
Cont:
        Dim LineItems As Variant: LineItems = Split(LineFromFile, ":")
        Set rngField = Range("1:1").Find(What:=LineItems(0), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
        
        If rngField Is Nothing Then
            col_number = Cells(1, Columns.Count).End(xlToLeft).Column
            ActiveCell.Offset(0, col_number + 1).Value = LineItems(0)
            ActiveCell.Offset(row_number + 1, col_number + 1).Value = LineItems(1)
        End If
        If Not rngField Is Nothing Then
            col_number = rngField.Column - 1
            ActiveCell.Offset(0, col_number).Value = LineItems(0)
            ActiveCell.Offset(row_number + 1, col_number).Value = LineItems(1)
        End If
        col_number = col_number + 1
    Loop


    Close #1
    Cells.Columns.AutoFit
    
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = LC To 1 Step -1
        If Cells(1, i) = "" Then Columns(i).Delete
    Next
    Application.ScreenUpdating = True
    End
NewRecord:
    If col_number = 0 Then GoTo Cont
    If col_number > 0 Then
        row_number = row_number + 1
        col_number = 0
    End If
    GoTo Cont
    
End Sub

Please let me know how you make out!

igold

 

[mikerickson]

I think this will do what you want
It assumes that you have two sheets in the Workbook. Record is where you want the data and Import is a working sheet to take the import from the Txt file.
(Why not just copy the e-mail to a blank Excel sheet rather than going through a txt file?)

Sub test()
    Dim rngArchive As Range
    Dim rngImport As Range
    Dim PathToTXT As String
    Dim recordStart As Range, recordEnd As Range
    Dim oneRecord As Range
    Dim firstFound As String
    
    Const FirstFieldName As String = "First_Name"
    Set rngImport = ThisWorkbook.Sheets("Import").Range("A1"): Rem adjust
    Set rngArchive = ThisWorkbook.Sheets("Record").Range("A1"): Rem adjust
    PathToTXT = "TEXT;Macintosh HD:Users:michaelerickson:Desktop:test.txt": Rem adjust

    ImportTextFile rngImport, PathToTXT
    Set rngImport = rngImport.EntireColumn
    Set recordStart = rngImport.Find(what:=FirstFieldName, after:=rngImport.Cells(Rows.Count, 1), LookAt:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext, MatchCase:=False)
    If recordStart Is Nothing Then
        MsgBox "problem"
        Exit Sub
    End If
    firstFound = recordStart.Address
    
    Do
        Set recordEnd = rngImport.FindNext(after:=recordStart)
        If (recordEnd Is Nothing) Or (recordEnd.Address = firstFound) Then
            Set recordEnd = rngImport.Cells(Rows.Count, 1).End(xlUp)
        Else
            Set recordEnd = recordEnd.Offset(-1, 0)
        End If
        Set oneRecord = Range(recordStart, recordEnd).Resize(, 2)
        ProcessOneRecord oneRecord, rngArchive
        Set recordStart = rngImport.FindNext(after:=recordStart)
    Loop Until recordStart.Address = firstFound
    
End Sub

Sub ProcessOneRecord(ByVal rngRecord As Range, ByVal rngArchive As Range)
    Dim arrHeaders As Variant
    Dim InputRow As Range
    Dim colMatching As Variant
    Dim arrNewArchive() As String
    Set rngArchive = rngArchive.Cells(1, 1).CurrentRegion
    arrHeaders = rngArchive.Rows(1).Value
    ReDim arrNewArchive(1 To rngArchive.Columns.Count)
    For Each InputRow In rngRecord.Rows
        colMatching = Application.Match(InputRow.Cells(1, 1).Value, arrHeaders, 0)
        If IsError(colMatching) Then
            ReDim Preserve arrHeaders(1 To 1, 1 To UBound(arrHeaders, 2) + 1)
            ReDim Preserve arrNewArchive(1 To UBound(arrHeaders, 2))
            arrHeaders(1, UBound(arrHeaders, 2)) = InputRow.Cells(1, 1).Value
            rngArchive.Resize(1, UBound(arrHeaders, 2)).Value = arrHeaders
            Set rngArchive = rngArchive.Cells(1, 1).CurrentRegion
            colMatching = UBound(arrHeaders, 2)
        End If
        arrNewArchive(colMatching) = WorksheetFunction.Trim(InputRow.Cells(1, 2).Value)
    Next InputRow
    rngArchive.Offset(rngArchive.Rows.Count).Resize(1).Value = arrNewArchive
End Sub

Sub ImportTextFile(DestinationRange As Range, Optional PathToTXT As String)
    If PathToTXT = vbNullString Then
        PathToTXT = "TEXT;Macintosh HD:Users:michaelerickson:Desktop:test.txt": Rem adjust
    End If
    With DestinationRange
        .Parent.Cells.Clear
        With .Parent.QueryTables.Add(Connection:= _
        "TEXT;Macintosh HD:Users:michaelerickson:Desktop:test.txt", Destination:=.Cells(1, 1))
        .Name = "test"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlMacintosh
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = ":"
        .TextFileColumnDataTypes = Array(2, 1)
        .Refresh BackgroundQuery:=False
        .UseListObject = False
        End With
    End With
End Sub

 

[igold]

Hey Jaredhott,

Did my post #11 ever work out for you?

igold