从文本文件中提取值

Question

我想使用 VBA Excel 从文本文件中提取数据。文本文件（工程软件的输出）包含很多值。 由于关键字总是位于值之前，我可以找到我感兴趣的值。

这是我的文本文件内容的典型示例：

random_text_before_keyword  [keyword1]       0.375    -0.080/   0.020      1.000
random_text_before_keyword  [keyword2]       0.530     0.367/   0.465      1.115
random_text_before_keyword  [keyword3]       0.363     0.200/   0.298      0.938
random_text_before_keyword  [keyword4]      19.225    21.206/   21.179     -71.834

一些困难：

1. 关键字和值用随机空格分隔（有时也用制表符分隔）
2. 值前面可以有“-”号（需要保留）
3. 有时值后面会有一个“/”字符（最好不要保留它）
4. 值不是整数（十进制数）
5. 值的长度不同

我的目标是在几行中提取四个值（例如 [keyword1] 和 [keyword3]）并将它们放入 Excel 工作表中：

A1; B1; C1; D1
A2; B2; C2; D2

目前，我找到了一个非常接近我可能需要做的主题，但我将不胜感激。 using excel vba read and edit text file into excel sheet

Answer 1

用于测试以下功能：

Sub Tester()

    Dim l As String, arr, gotMatch As Boolean, v

    'you will be reading this from a file....
    l = "random_text_before_keyword  blahblah  " & vbTab & _
          "   0.530     0.367/   0.465      1.115 "

    arr = ProcessLine(l, "blahblah", gotMatch)

    If gotMatch Then
        For Each v In arr
            Debug.Print v
        Next v
    End If

End Sub

处理每一行的函数：

Function ProcessLine(line As String, keyword As String, ByRef gotMatch As Boolean)

    Dim rv As String, arr, v

    gotMatch = InStr(line, keyword) > 0

    If gotMatch Then

        rv = Split(line, keyword)(1) 'part after the keyword
        'clean up...
        rv = Replace(rv, vbTab, " ")
        rv = Replace(rv, "/", "")
        Do While InStr(rv, "  ") > 0
            rv = Replace(rv, "  ", " ")
        Loop

        arr = Split(Trim(rv), " ")

     End If 'has keyword

     ProcessLine = arr 'return array

End Function

编辑 - 修正您的代码

rw = 1
myFile = "C:\vba\text.txt" 

Open myFile For Input As #1 

Do Until EOF(1) 

    Line Input #1, l 
    arr = ProcessLine(l, "[keyword1]", gotMatch) 

    If gotMatch Then 
        Cells(rw, 1).Resize(1, UBound(arr)+1).Value = arr 
        rw = rw + 1
    End If

Loop 

Close #1 

Answer 2

虽然我建议在导入日期时将其拆分，但之后您可以使用此子进行拆分。我假设总是有 4 个值，右侧的 5 个单元格是空的（将值放入）...原始单元格文本将保留（检查错误）

Sub splitit()
  Dim startCell As Range
  Set startCell = Range("A1")
  Dim cellValue As Variant
  While startCell <> ""
    cellValue = startCell.Value
    cellValue = Trim(Replace(Replace(cellValue, "/", ""), vbTab, ""))
    While InStr(cellValue, "  ")
      cellValue = Replace(cellValue, "  ", " ")
    Wend
    cellValue = Split(cellValue, " ")
    startCell.Offset(0, 1) = cellValue(UBound(cellValue) - 4)
    startCell.Offset(0, 2) = cellValue(UBound(cellValue) - 3)
    startCell.Offset(0, 3) = cellValue(UBound(cellValue) - 2)
    startCell.Offset(0, 4) = cellValue(UBound(cellValue) - 1)
    startCell.Offset(0, 5) = cellValue(UBound(cellValue))
    'activate the next 2 lines to change the original cell to the first part without the extracted text
    'ReDim Preserve cellValue(LBound(cellValue) To UBound(cellValue) - 5)
    'startCell.Value = Join(cellValue, " ")
    Set startCell = startCell.Offset(1, 0)
  Wend
End Sub

尝试改进并将其与您的导入合并，以便将来自动执行...

Answer 3

这可能会让你继续前进。不得不做一次类似的事情。

步骤：

1. 打开一个 Excel 工作表。
2. 按 ALT-F11。
3. 从菜单中选择“添加”。
4. 从下拉列表中选择“模块”。
5. 将下面的源代码复制到新创建的模块中。
6. 更改 Public Const 声明背后的值以满足您的需要
7. 运行调用导入

模块简述：

FindRow - 在表格中搜索关键字并返回找到关键字的单元格对象。

IsAnArry - 测试参数是否为数组类型。

CallImport - 开始导入的主子例程。

ImportEngineeringTextFile - 处理实际的导入和数据操作。

您唯一需要更改的是每个 Public Const 声明背后的值以满足您的需要，然后运行 ​​CallImport。在下面的代码中，我添加了一些注释以帮助理解那里发生了什么。

Public Const MY_IMPORT_TABLE_COLUMNS As String = "A:F"
Public Const FULL_PATH_TO_IMPORT_FILE_NAME As String = "Map1.txt"
Public Const COLUMS_WHERE_TO_DELETE_SLASH As String = "D:D"
Public Const COLUMNS_TO_DELETE_WHEN_DONE As String = "A:B"
Public Const DESTINATION_CELL_FOR_DATA As String = "A1"
Public Const FIRST_COLUMN_OF_MY_TABLE As String = "A:A"
Public Const KEYWORDS_1 As Variant = "[keyword1]"
Public Const KEYWORDS_2 As Variant = "[keyword3]"
'You can add more keyword declarations if need be.
'If you do so, don't forget to change the call to ImportEngineeringTextFile
'in CallImport

Function FindRow(What As Variant) As Object
    With ActiveSheet.Range(MY_IMPORT_TABLE_COLUMNS)
        Set FindRow = .Find(What, After:=.Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues, MatchCase:=False, LookAt:=xlWhole)
    End With
End Function

Function IsAnArray(VAR As Variant) As Boolean
    Dim I As Long
    On Error Resume Next
    I = VAR.Rows.Count
    IsAnArray = ((VarType(VAR) > vbArray Or InStr(TypeName(VAR), "()") < 1) And Err.Number <> 0)
End Function

Sub CallImport()
    Call ImportEngineeringTextFile(Array(KEYWORDS_1, KEYWORDS_2)) ' Add other keyword constants to the array if need be.
End Sub

Sub ImportEngineeringTextFile(ByVal KeyWords As Variant)
    Dim KWord As Variant, Obj As Object, ValidRows() As Variant, I As Long, R As Variant
    If Not IsAnArray(KeyWords) Then Exit Sub ' If the import parameter is not of type Array, do not continue.
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & FULL_PATH_TO_IMPORT_FILE_NAME, Destination:=Range(DESTINATION_CELL_FOR_DATA))
        .Name = "Map1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells  ' This makes sure you can import over and over again with the same paramters, without cleaning the sheet first
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True ' Automatically adjust width of column after import
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False ' Do not ask for a filename
        .TextFilePlatform = 850 ' Data in file is of code page IMB850 (ANSI)
        .TextFileStartRow = 1 ' Import as from row 1
        .TextFileParseType = xlDelimited ' This indacates a delimited fields file in stead of fixed field length file
        .TextFileTextQualifier = xlTextQualifierDoubleQuote ' This indactes that data starting with double quote is considered to be text
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True ' Fields can be seperated by tab character
        .TextFileSemicolonDelimiter = False ' Fields can not be separated by semi-colon
        .TextFileCommaDelimiter = False ' Fields can not be separated by comma
        .TextFileSpaceDelimiter = True ' Fields can be separated by a space
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1) ' Data types of imported fields, need no changing since they are all set to automatic detection
        .TextFileTrailingMinusNumbers = True ' Negative values can have trailing a negation sign
        .Refresh BackgroundQuery:=False
    End With
    Columns(COLUMS_WHERE_TO_DELETE_SLASH).Select
    Selection.Replace What:="/", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range(DESTINATION_CELL_FOR_DATA).Select
    I = 0
    ReDim ValidRows(I)
    Set ValidRows(0) = Nothing
    For Each KWord In KeyWords ' Search for and store the rows where the keywords are found
        Set Obj = FindRow(KWord)
        If Not Obj Is Nothing Then ' A row was found containing a keyword
            ReDim Preserve ValidRows(I) ' Allocate more space for the resulting array
            Set ValidRows(I) = Obj
            I = I + 1
        End If
    Next
    For Each Obj In Range(FIRST_COLUMN_OF_MY_TABLE) ' Walk through the data table and delete all rows that do not contain one of the specified keywords
        If Obj.Value = "" Then Exit For
        I = 0
        For Each R In ValidRows 
            If Obj.Row = R.Row Then
                I = 1
                Exit For
            End If
        Next
        If I = 0 Then Obj.EntireRow.Delete Shift:=xlUp ' Delete a row
    Next
    Columns(COLUMNS_TO_DELETE_WHEN_DONE).EntireColumn.Delete Shift:=xlLeft ' Delete those columns you do not want to keep in the data table
End Sub