时间戳

首页 > 解决方案 > 将 .txt 导入中的不规则数据转置到 Excel 中的表格中

excel - 将 .txt 导入中的不规则数据转置到 Excel 中的表格中

问题描述

我已经从 Word -> .txt -> Excel 的表格中导入了一堆数据，但是在转换为 .txt 时表格的格式丢失了，我现在正试图在 Excel 中恢复它。

我只是根据单元格范围制作一个简单的复制/粘贴宏，但是每个导入的 .txt 文件中的单元格范围都不相同，因此这将不起作用，因为相同的数据可能在一张纸中的 A8 中，然后在 A10 中其他。您几乎可以将每隔一行移到 B 列，但“到期日期”字段会使其不同步。

我想将复制的日期转换为更实用的表格格式 -例如参见图片- 然后我可以对其进行分析。我需要为数百张纸做这个，但我希望如果我能让它为一张纸工作，那么我可以让它适应很多张。

每张表可能有多个产品，每个新产品前面都有一个整数（例如 1. Product1; 2. Product2 等...）

删除了我试图做的旧代码

EDIT2： 典型记事本文件的截图

上面有很多文字，但第一个产品总是以 QUOTATION MACHINE SCHEDULE 开头，然后是 1.xxx

编辑3：

试图在I列中添加Quote Ref:并在文本文件中找到它，但它没有用。从以下 CDP1802 当前解决方案的代码更改

'results sheet

Set ws = ThisWorkbook.Sheets("Results")
ws.Range("A1:I1") = Array("Item", "Date Due", "Type", "Serial Number", "Standard", "Mode", "Range", "Location", "Quote Ref:")
r = 1 ' output row
   

 Select Case s
    ' match word to set column
    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 "Quote Ref:": c = 9
    Case Else: c = 0
 End Select

报价参考的新截图：

标签： excelvba

解决方案

将文本文件读入一个数组，然后使用 Select Case 扫描关键词。将数据读入数组允许您从关键字下方的行中选择值。

更新 - 添加了引用参考

Option Explicit

Sub ProcessTextFiles1()

   Const FOLDER = "C:\temp\SO\Data\" ' folder where the text files are

   Dim ws As Worksheet, sFilename As String, sQuoteRef As String
   Dim n As Integer, i As Long, r As Long, c As Long
   Dim fso As Object, ts As Object, ar() As String, s As String

   Set fso = CreateObject("Scripting.FileSystemObject")

   ' results sheet
   Set ws = ThisWorkbook.Sheets("Results")
   ws.Range("A1:I1") = Array("Item", "Date Due", "Type", "Serial Number", _
                              "Standard", "Mode", "Range", "Location", "Quote Ref")
   r = 1 ' output row

   ' scan each file in folder
   sFilename = Dir(FOLDER & "*.txt")
   Do While Len(sFilename) > 0
        n = n + 1
        sQuoteRef = ""
        
        ' open file and read into array
        Set ts = fso.OpenTextFile(FOLDER & sFilename)
        s = ts.readAll
        s = Replace(s, vbLf, "")
        ar = Split(s, vbCr)
        ts.Close
        'MsgBox sFilename & "=" & UBound(ar)

        ' parse the strings in the array
        i = 0
        Do While i <= UBound(ar)
            s = LCase(Trim(ar(i)))
            'Debug.Print s
            If Len(s) > 0 Then ' skip blanks

                If Left(s, 10) = "quote ref:" Then
                    sQuoteRef = ar(i + 1)
                End If

                If Left(s, 2) Like "#." Or Left(s, 3) Like "##." Then
                    ' new product
                    r = r + 1
                    ws.Cells(r, 1) = ar(i)
                    ws.Cells(r, 9) = sQuoteRef
                Else
                    Select Case s
                        ' match word to set column
                        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

                    ' take value below
                    If c = 4 Then
                        ws.Cells(r, 4) = ar(i + 1)
                        ws.Cells(r, 2) = ar(i + 2) ' due date
                        i = i + 2
                    ElseIf c > 1 Then
                        ws.Cells(r, c) = ar(i + 1)
                        i = i + 1
                    End If
                End If
            End If
            i = i + 1
        Loop
        sFilename = Dir
    Loop
    MsgBox n & " Files processed", vbInformation
End Sub

推荐阅读