如何将txt导入Excel的不规则数据转置为可分析的结构化表格

问题原因 #

你匹配不到Quote Ref:字段主要有两个原因：

• 该字段一般位于文件头部的冗余文本区域，不在产品条目内部，你现有逻辑是进入产品条目后才匹配字段，自然扫不到头部的内容
• 字符串匹配没有做预处理，文本中可能存在前后空格、大小写差异，导致Select Case匹配失败

修改后实现代码 #

Sub 整理结构化数据()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long, r As Long, c As Long
    Dim quoteRef As String, s As String
    Dim isStartParse As Boolean
    
    ' 初始化结果表
    Set wsResult = ThisWorkbook.Sheets("Results")
    wsResult.Cells.Clear
    wsResult.Range("A1:I1") = Array("Item", "Date Due", "Type", "Serial Number", "Standard", "Mode", "Range", "Location", "Quote Ref:")
    r = 1 ' 结果表当前输出行
    isStartParse = False ' 是否开始解析产品条目
    quoteRef = "" ' 全局存储Quote Ref值
    
    ' 遍历当前激活的数据源工作表，后续可套循环遍历所有工作表
    Set wsSource = ActiveSheet
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    For i = 1 To lastRow
        s = Trim(wsSource.Cells(i, "A").Value)
        If s = "" Then GoTo nextLine
        
        ' 先匹配全局Quote Ref字段，不管有没有进入解析流程
        If InStr(1, s, "Quote Ref:", vbTextCompare) > 0 Then
            quoteRef = Trim(Replace(s, "Quote Ref:", "", , , vbTextCompare))
            GoTo nextLine
        End If
        
        ' 匹配到起始标记后才开始解析产品
        If InStr(1, s, "QUOTATION MACHINE SCHEDULE", vbTextCompare) > 0 Then
            isStartParse = True
            GoTo nextLine
        End If
        
        If isStartParse Then
            ' 判断是不是新产品行：格式为 数字. 产品名
            If s Like "#.*" Or s Like "##.*" Or s Like "###.*" Then
                r = r + 1
                ' 提取产品名，去掉前面的序号和点
                wsResult.Cells(r, "A").Value = Trim(Mid(s, InStr(s, ".") + 1))
                ' 新产品行直接填入已经提取到的Quote Ref
                wsResult.Cells(r, "I").Value = quoteRef
                GoTo nextLine
            End If
            
            ' 判断是不是Date Due行，单独处理避免错位
            If InStr(1, s, "Date Due", vbTextCompare) > 0 Then
                wsResult.Cells(r, "B").Value = Trim(Replace(s, "Date Due", "", , , vbTextCompare))
                GoTo nextLine
            End If
            
            ' 匹配其他字段，先转小写、去空格再匹配
            Select Case LCase(Trim(Split(s, ":")(0)))
                Case "type": c = 3
                Case "serial number": c = 4
                Case "standard": c = 5
                Case "mode": c = 6
                Case "range": c = 7
                Case "location": c = 8
                Case Else: c = 0
            End Select
            
            If c > 0 Then
                ' 提取冒号后面的内容作为值
                If InStr(s, ":") > 0 Then
                    wsResult.Cells(r, c).Value = Trim(Mid(s, InStr(s, ":") + 1))
                Else
                    wsResult.Cells(r, c).Value = Trim(s)
                End If
            End If
        End If
nextLine:
    Next i
    
    ' 自动调整结果表列宽
    wsResult.Columns("A:I").AutoFit
    MsgBox "当前工作表整理完成，共整理" & r - 1 & "条产品数据"
End Sub

使用说明 #

1. 单工作表测试：打开需要整理的工作表，直接运行宏即可，结果会输出到Results表中
2. 多工作表适配：在外层套一层遍历ThisWorkbook.Worksheets的循环，把Set wsSource = ActiveSheet替换为循环的工作表对象即可，注意多表处理时不要重复累加r变量，或者每个表的结果追加到Results表末尾即可

内容的提问来源于stack exchange，提问作者user16766172