Excel 2013 : Pull Matching Data from Column

Question

I have huge amount of data in below format.

**M A Enterprises ~**
Member No: M-551/IV/A
Category: Food and vegetables
Year of Established: 1984
Address: Address line 1 
Address Line 2
Address Line 3
Address Line 4
Address Line 5
Phone: 11111111, 22222222
Fax: 33333333
Email: somemail@gmail.com
Website:www.somewebsite.com
Executive1: Mr. Ashok Kumar
Designation: Owner
Mobile: 9999999999
Executive2: Rahul Bhai
Designation: Director
Mobile: 3333333333
Product: food product processing
Rawmaterial: Ss Hot Rolled
**A B Enterprises ~**
Member No: M-552/IV/A
Category: Food and vegetables
Year of Established: 1984
Address: Address line 1 
Address Line 2
Address Line 3
Address Line 4
Address Line 5
Phone: 11111111, 22222222
Fax: 33333333
Email: somemail@gmail.com
Executive1: Mr. Ashok Kumar
Mobile: 9999999999
Executive2: Rahul Bhai
Mobile: 3333333333
Product: food product processing

As you can see, there are 2 sets of data here. 1st line is a company name (in bold letters). It has no FIELD NAME, but a trailing "~" along with space after company name.

Total of maximum 17 fields (company name, member no, Category etc) in each set. Second set has only 16 fields (raw material is not there)

Some fields are not present in every set, Like Fax, Designation, Website, Email.

There is no GAP (space, paragraph) between 2 sets. Every set either ends with "Product" or "Rawmaterial". "Rawmaterial is not that important information, If needed, I can drop this.

Address lines are flexible, it can be 3 to 5 lines, but does not exceed 6 or 7 in any of the entries.

Another issue is "Designation" which appears 2 times in some entries. First one comes after "Executive1" and second comes after "Executive2". Same thing with "Mobile".

Currently data is in PLAIN TEXT format, but i could pull it in excel with ":" as delimiter. Thereafter there will be 2 columns, A1=Member No and B1=M-551/IV/A (and so on), Cant help with company name as there is no ":" sign in it.

Thousands of sets are there, so i need to find a way to do this anyhow.

What I am trying to achieve:

In Excel,

• C1 - Company Name (this is heading title)
• C2 - M A Enterprises
• C3 - A B Enterprises

and so on, row by row, till the final set.

• D1 - Member No (this is heading title)
• D2 - M-551/IV/A
• D3 - M-552/IV/A

and so on...

Same with other fields.

I did my best to try VLookup, Match, Find functions, but not getting any results.

Any help would be great. Thanks.

Answer 1

Below vba code should help. It's been written under the assumption that "~" would appear only in Company Name.

Sub sTexttoExcel()

'Input File Path
filePath = "C:\CustomerData.txt"

Dim fso As FileSystemObject
Dim HeaderName() As String
Dim cellcontent As String
Dim CompanyDetails(2) As String
Dim RowCount, ColoumnCount As Integer
Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile(filePath, ForReading, False)

'Initialise Row and Column count
RowCount = 1
ColoumnCount = 1
coloumnheadercount = 0
RowHeaderCount = 0

'Loop through contents of text file to print headers
Do While Not txtStream.AtEndOfStream
    cellcontent = txtStream.ReadLine
    If InStr(1, cellcontent, "~", vbTextCompare) <> 0 Then
        'Print the header row
        RowHeaderCount = RowHeaderCount + 1
        coloumnheadercount = coloumnheadercount + 1
        If RowHeaderCount = 2 Then Exit Do
        Cells(1, coloumnheadercount) = "Company Name"
    ElseIf InStr(1, cellcontent, ":", vbTextCompare) <> 0 Then
        coloumnheadercount = coloumnheadercount + 1
        ReDim Preserve HeaderName(1 To coloumnheadercount)
        HeaderName(coloumnheadercount - 1) = Split(cellcontent, ":")(0)
        Cells(1, coloumnheadercount) = Split(cellcontent, ":")(0)
    End If
Loop
txtStream.Close

Set txtStream = fso.OpenTextFile(filePath, ForReading, False)
'Loop through contents of text file
Do While Not txtStream.AtEndOfStream
    cellcontent = txtStream.ReadLine

    'Store details of Executives in a seperate array
    If InStr(1, cellcontent, "Executive", vbTextCompare) <> 0 Then
        CompanyDetails(0) = cellcontent
    End If
    If InStr(1, cellcontent, "Designation", vbTextCompare) <> 0 Then
        CompanyDetails(1) = cellcontent
    End If
    If InStr(1, cellcontent, "Mobile", vbTextCompare) <> 0 Then
        CompanyDetails(2) = cellcontent
    End If

    'Check if it is a company name
    If InStr(1, cellcontent, "~", vbTextCompare) <> 0 Then
        RowCount = RowCount + 1
        ColoumnCount = 1
        Cells(RowCount, ColoumnCount) = cellcontent

    'Check if it has the text 'Address'
    ElseIf InStr(1, cellcontent, "Address", vbTextCompare) <> 0 Then
        If InStr(1, cellcontent, ":", vbTextCompare) <> 0 Then
            ColoumnCount = ColoumnCount + 1
            Cells(RowCount, ColoumnCount) = Cells(RowCount, ColoumnCount) & Trim(Split(cellcontent, ":")(1)) & vbCrLf
        Else
            Cells(RowCount, ColoumnCount) = Cells(RowCount, ColoumnCount) & cellcontent & vbCrLf
        End If

    'Check if it has the text 'Designation'
    ElseIf InStr(1, cellcontent, "Designation", vbTextCompare) <> 0 Then
        ColoumnCount = ColoumnCount + 1
        If InStr(1, CompanyDetails(0), "Executive1", vbTextCompare) <> 0 Then
            Call writeCell(cellcontent, RowCount, 11)
        ElseIf InStr(1, CompanyDetails(0), "Executive2", vbTextCompare) <> 0 Then
            Call writeCell(cellcontent, RowCount, 14)
        End If

    'Check if it has the text 'Mobile'
    ElseIf InStr(1, cellcontent, "Mobile", vbTextCompare) <> 0 Then
        ColoumnCount = ColoumnCount + 1
        If InStr(1, CompanyDetails(0), "Executive1", vbTextCompare) <> 0 Then
            Call writeCell(cellcontent, RowCount, 12)
        ElseIf InStr(1, CompanyDetails(0), "Executive2", vbTextCompare) <> 0 Then
            Call writeCell(cellcontent, RowCount, 15)
        End If

    Else
        ColoumnCount = ColoumnCount + 1
        For i = 1 To UBound(HeaderName) - 1
            If InStr(1, cellcontent, HeaderName(i), vbTextCompare) <> 0 Then Call writeCell(cellcontent, RowCount, i + 1)
        Next i
    End If

    Loop
txtStream.Close

End Sub

Sub writeCell(ByVal cellcontent As String, ByVal RowCount As Integer, ByVal ColoumnCount As Integer)
    Cells(RowCount, ColoumnCount) = Trim(Split(cellcontent, ":")(1))
End Sub