Excel 2013：从列中提取匹配数据

debugcn 发表于 Dev

拉胡尔

我有以下格式的大量数据。

**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: [email protected]
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: [email protected]
Executive1: Mr. Ashok Kumar
Mobile: 9999999999
Executive2: Rahul Bhai
Mobile: 3333333333
Product: food product processing

如您所见，这里有2组数据。第一行是公司名称（粗体字母）。它没有FIELD NAME，但在公司名称后跟一个空格后跟一个“〜”。

每组中最多包含17个字段（公司名称，会员编号，类别等）。第二组只有16个字段（原始材料不存在）

并非每个集合中都包含某些字段，例如传真，名称，网站，电子邮件。

2套之间没有GAP（空格，段落）。每一套都以“产品”或“原材料”结尾。“原材料不是那么重要的信息，如果需要，我可以删除它。

地址线是灵活的，可以是3到5条线，但在任何条目中都不能超过6或7。

另一个问题是“名称”，在某些条目中出现2次。第一个在“ Executive1”之后，第二个在“ Executive2”之后。与“移动”相同。

当前数据是PLAIN TEXT格式的，但是我可以使用“：”作为分隔符将其拉入excel。此后将有2列，A1 =会员编号，B1 = M-551 / IV / A（依此类推），不能使用公司名称作为帮助，因为其中没有“：”符号。

那里有成千上万套，所以无论如何我需要找到一种方法。

我想要达到的目标：

在Excel中，

C1-公司名称（这是标题）
C2-MA企业
C3-AB企业

依此类推，直到最后一组。

D1-会员编号（这是标题）
D2-M -551 / IV / A
D3-M -552 / IV / A

等等...

与其他字段相同。

我尽力尝试了VLookup，Match，Find函数，但没有得到任何结果。

任何帮助将是巨大的。谢谢。

巴拉戈文德

下面的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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。