我有以下格式的大量数据。
**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
如您所见，这里有2组数据。第一行是公司名称（粗体字母）。它没有FIELD NAME，但在公司名称后面跟有空格“〜”。
每组中最多17个字段（公司名称，成员编号，类别等）的总计。第二组只有16个字段（原材料不存在）
某些字段不存在于每个集合中，如传真，指定，网站，电子邮件。
2套之间没有GAP（空格，段落）。每一组都以“Product”或“Rawmaterial”结尾。 “Rawmaterial不是那么重要的信息，如果需要，我可以放弃它。
地址线是灵活的，可以是3到5行，但在任何条目中都不超过6或7。
另一个问题是“指定”，在某些条目中出现2次。第一个出现在“Executive1”之后，第二个出现在“Executive2”之后。 “移动”也是如此。
目前数据采用PLAIN TEXT格式，但我可以用excel中的“：”作为分隔符将其拉出来。此后将有2列，A1 =会员号，B1 = M-551 / IV / A（依此类推），由于没有“：”符号，因此无法帮助公司名称。
有数千套装，所以我无论如何都需要找到一种方法。
我想要实现的目标：
在Excel中，
依此类推，一行一行，直到最后一集。
依旧......
与其他领域相同。
我尽力尝试VLookup，Match，Find功能，但没有得到任何结果。
任何帮助都会很棒。感谢。
答案 0 :(得分：0)
以下vba代码应该有所帮助。它的编写假设“〜”只出现在公司名称中。
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