Excel VBA - 从多个文本文件中提取包含特定名称的行

Question

尝试从文本文件中提取文本行到 Excel，但前提是它们在该行中包含特定名称。忽略其余的行。

我目前正在处理大量包含某些产品的标准化信息的文本文件。每个文件都有相同的产品列表，但信息来自不同的日期。我已经整理了一些代码，这些代码从目录中包含的文本文件中提取每一行，并将它们一起包含在一个 Excel 电子表格中。

我想更改的是代码仅复制包含行内特定名称的文本行，例如“大写索引”。其余数据可以忽略。这是为了减少提取数据所需的时间，因为每个文本文件中只需要大约 5% 的行。

Sub ReadFilesIntoActiveSheet()
    Dim fso As FileSystemObject
    Dim folder As folder
    Dim file As file
    Dim FileText As TextStream
    Dim TextLine As String
    Dim Items() As String
    Dim i As Long
    Dim cl As Range
    ' Get a FileSystem object
    Set fso = New FileSystemObject
    ' get the directory you want
    Set folder = fso.GetFolder("C:\Users\crowe12\Desktop\Projects\CRSP\Test")
    Set cl = ActiveSheet.Cells(1, 1)
    For Each file In folder.Files
        Set FileText = file.OpenAsTextStream(ForReading)
        Do While Not FileText.AtEndOfStream
            TextLine = FileText.ReadLine
            Items = Split(TextLine, "|")
            cl.Value = folder & "\" & file.Name
            For i = 0 To UBound(Items)
                cl.Offset(0, i + 1).Value = Items(i)
            Next
            Set cl = cl.Offset(1, 0)
        Loop
        FileText.Close
    Next file
    Set FileText = Nothing
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
End Sub

Answer 1

您可以使用以下方式测试每一行：

Dim x As Long
x = 1
For i = 0 To UBound(Items)
    If Items(i) Like "*your value here*" Then
        cl.Offset(0, x).Value = Items(i) '<< this offsets to the right: 
                                         '   did you mean to offset down?
        x = x + 1
    End If

Next

Answer 2

当您阅读该行时，为什么不检查您想要的文本是否存在于其上，然后根据检查跳过它

Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim textToSkip as String: textToSkip="Large Cap Index"
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\crowe12\Desktop\Projects\CRSP\Test")
Set cl = ActiveSheet.Cells(1, 1)
For Each file In folder.Files
    Set FileText = file.OpenAsTextStream(ForReading)
    Do While Not FileText.AtEndOfStream
        TextLine = FileText.ReadLine
        'You can covert this to lowercase before hand to match ignoring case
        If Instr(1,TextLine,textToSkip) > 1 Then
         Items = Split(TextLine, "|")
         cl.Value = folder & "\" & file.Name
         For i = 0 To UBound(Items)
          cl.Offset(0, i + 1).Value = Items(i)
         Next
         Set cl = cl.Offset(1, 0)
        End If
    Loop
    FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub

除了条件之外，我对你的代码没有太大的改变