从多个文件夹中的多个文本文件中读取特定行

Question

我在几个文件夹中有大量文本文件，我需要每个文本文件的第 14 行，我想知道是否有办法这样做？

目前我有以下脚本设置，其中我将文件夹目录输入到第一个工作表中的单元格 A19 中，这将返回目录中所有文件的文件路径。然后我想利用上述文件路径从每个文本文件的第 14 行获取信息。这是我的 到目前为止的代码：

Private Sub CommandButton1_Click()


'Call the recursive function
    ListAllFiles ThisWorkbook.Sheets(1).Range("A19").Value, ThisWorkbook.Sheets(2).Cells(1, 1)
    ReadTxtFiles
    MsgBox "Task Completed"


 End Sub

---

Private Sub ListAllFiles(root As String, targetCell As Range)
    Dim objFSO As Object, objFolder As Object, objSubfolder As Object, objFile As Object
    Dim i As Integer, Target_Path As String

'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(root)
'loops through each file in the directory and prints their names and path

For Each objFile In objFolder.Files
    'print file name
    targetCell.Value = objFile.Name
    'print file path
    targetCell.Offset(, 1).Value = objFile.Path
    'print file type
    'targetCell.Offset(, 2).Value = objFile.Type
    'print file date created
    'targetCell.Offset(, 3).Value = objFile.DateCreated
    'print file date last accessed
    'targetCell.Offset(, 4).Value = objFile.DateLastAccessed
    'print file date last modified
    'targetCell.Offset(, 5).Value = objFile.DateLastModified
    Set targetCell = targetCell.Offset(1)
Next objFile

' Recursively call the function for subfolders
For Each objSubfolder In objFolder.SubFolders
    ListAllFiles objSubfolder.Path, targetCell
    Next objSubfolder
End Sub

---

Private Sub ReadTxtFiles()

    'Dim start As Date
'start = Now

Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

Dim oFS As Object


'''''Assign the Workbook File Name along with its Path
'''''Change path of the Target File name

Dim v As Variant, filepath As String
For Each v In Worksheets("Sheet2").Columns("B").SpecialCells(xlCellTypeConstants)
filepath = v.Value
Debug.Print filepath


Dim arr(100000) As String
Dim i As Long
i = 0

If oFSO.FileExists(filepath) Then
    On Error GoTo Err

    Set oFS = oFSO.OpenTextFile(filepath)
    Do While Not oFS.AtEndOfStream
        arr(i) = oFS.ReadLine
        i = i + 1
    Loop
    oFS.Close
Else
    MsgBox "The file path is invalid.", vbCritical, vbNullString
    Exit Sub
End If

---

这就是我卡住的地方。我想阅读每个文本文件并获取每个文件的第 14 行，仅此而已。

Answer 1

您的ReadTxtFiles 子例程似乎读入了数据，然后什么也不做。也许它在您未发布的代码部分中做了一些事情。

但是，相对直接地只读取 14 行，然后最后读取的内容就是您想要的记录：

Private Sub ReadTxtFiles()

    'Dim start As Date
    'start = Now

    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Dim oFS As Object


    '''''Assign the Workbook File Name along with its Path
    '''''Change path of the Target File name

    Dim v As Variant, filepath As String
    For Each v In Worksheets("Sheet2").Columns("B").SpecialCells(xlCellTypeConstants)
        filepath = v.Value
        Debug.Print filepath


        Dim rec As String
        Dim i As Long
        i = 0
        rec = ""

        If oFSO.FileExists(filepath) Then
            On Error GoTo Err

            Set oFS = oFSO.OpenTextFile(filepath)
            Do While Not oFS.AtEndOfStream
                rec = oFS.ReadLine
                i = i + 1
                If i = 14 Then Exit Do
            Loop
            oFS.Close
        Else
            MsgBox "The file path is invalid.", vbCritical, vbNullString
            Exit Sub
        End If

        'Check we read 14 records
        If i < 14 Then
            MsgBox "Not enough records"
            Exit Sub
        End If

        'do whatever you want with "rec"
        '...
        '...

Answer 2

这有帮助吗？要测试，请在设置路径和文件名后运行过程TestGetLine。

Private Sub TestGetLine()
    ' 12 Apr 2017

    Dim Pn As String                                ' Path
    Dim Fn As String                                ' File
    Dim Ffn As String

    Pn = "D:\My Documents\"
    Fn = "TextFile 14"
    Ffn = Pn & Fn & ".txt"
    If Len(Dir(Ffn)) Then
        Debug.Print TextLine(Ffn, 14)
    Else
        MsgBox Chr(34) & Fn & """ doesn't exist.", _
               vbInformation, "Invalid file name"
    End If
End Sub

Private Function TextLine(ByVal Ffn As String, _
                          LineNum As Integer) As String
    ' 12 Apr 2017

    Dim FileNum As Integer
    Dim Txt As String
    Dim Ln As Integer

    Close                           ' close any open text files
    FileNum = FreeFile
    Open Ffn For Input As #FileNum
    Do While Not EOF(1)             ' Loop until end of file.
        Line Input #1, Txt
        Ln = Ln + 1
        If Ln = LineNum Then Exit Do
    Loop
    If Ln < LineNum Then
        Txt = "File """ & Split(Ffn, "\")(UBound(Split(Ffn, "\"))) & _
               """ has only " & Ln & " lines. No line was copied"
    End If
    Close
    TextLine = Txt
End Function

您可以在需要的任何循环中提供路径 (Pn) 和文件名 (Fn)。让代码添加扩展名.txt。在函数调用中指定您想要的行号，例如 TextLine(Ffn, 14) 指定第 14 行。

Answer 3

自从我完成 VBA 以来已经有很长时间了，但是要找到事物的第 n 次迭代，请使用 MOD。 This is explains how to use it 还有很多其他的例子你可以在网上找到。