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

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

vba excel

Vba 从多个文件夹中的多个文本文件中读取特定行,vba,excel,Vba,Excel,我在几个文件夹中有大量文本文件，我需要每个文本文件的第14行，我想知道是否还有其他方法可以这样做目前，我有以下脚本设置，其中我将文件夹目录输入到第一个工作表中的单元格A19中，这将返回目录中所有文件的文件路径。然后，我想利用前面提到的文件路径，从每个文本文件的第14行获取信息。这是我的迄今为止的代码： Private Sub CommandButton1_Click() 'Call the recursive function ListAllFiles ThisWorkbook.

我在几个文件夹中有大量文本文件，我需要每个文本文件的第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

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

我已经很长时间没有使用VBA了，但要找到某件事情的第n次迭代，请使用MOD。还有很多其他的例子，你可以在网上找到。

你的

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"
        '...
        '...

Private Sub ReadTxtFiles（）
'开始日期为'
'开始=现在
物体的暗度
Set of so=CreateObject（“Scripting.FileSystemObject”）
作为对象的模糊oFS
指定工作簿文件名及其路径
“更改目标文件名的路径”
Dim v作为变量，filepath作为字符串
对于工作表（“表2”）.列（“B”）.特殊单元格（xlCellTypeConstants）中的每个v
filepath=v.Value
调试.打印文件路径
作为字符串的Dim rec
我想我会坚持多久
i=0
rec=“”
如果存在oFSO.FILE（文件路径），则
上错下错
Set of s=of so.OpenTextFile（文件路径）
不使用S.AtEndOfStream时请勿使用
rec=oFS.ReadLine
i=i+1
如果i=14，则退出Do
环
好的，结束
其他的
MsgBox“文件路径无效。”，vbCritical，vbNullString
出口接头
如果结束
“我们看了14条记录
如果我<14那么
MsgBox“记录不足”
出口接头
如果结束
'用“rec”做任何你想做的事'
'...
'...

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

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

Private子TestGetLine（）
2017年4月12日
将Pn设置为字符串的路径
Dim Fn作为“字符串”文件
模糊Ffn作为字符串
Pn=“D:\My Documents\”
Fn=“TextFile 14”
Ffn=Pn&Fn&“.txt”
如果Len（Dir（Ffn））那么
调试.打印文本行（Ffn，14）
其他的
MsgBox Chr（34）&Fn&“不存在”_
vbInformation，“无效文件名”
如果结束
端接头
专用函数文本行（ByVal Ffn作为字符串_
LineNum（作为整数）作为字符串
2017年4月12日
Dim FileNum作为整数
以字符串形式显示文本
作为整数的Dim Ln
“关闭”关闭所有打开的文本文件
FileNum=FreeFile
打开Ffn作为#FileNum输入
在文件结束前不要执行EOF（1）循环。
行输入#1，Txt
Ln=Ln+1
如果Ln=LineNum，则退出Do
环
如果Ln


您可以在所需的循环中输入路径（Pn
）和文件名（Fn
）。让代码添加扩展名.txt
。在函数调用中指定所需的行号，如TextLine（Ffn，14）
指定第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"
        '...
        '...

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