将文本从.txt文件读取到另一个工作表中

Question

我已从其他地方获取此代码，因为我不知道如何编码...我只需要帮助如何将此文件打印到工作簿中的不同工作表中，让我们说第3页，目前它只是在表1中打印。我知道它可能很简单，但我在过去的一小时内尝试过，而且我一直都会遇到错误。

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



For i = LBound(arr) To UBound(arr)
    If InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A20").Value, vbTextCompare) Then

    'While value in 'ThisWorkbook.Sheets(1).Range("A20").Value' has not been found,
    'keep looping to print out contents starting from 'ThisWorkbook.Sheets(1).Range("A21").Value'
    Do While InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A21").Value, vbTextCompare) = 0

        Debug.Print i + 1,
        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
        Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)



        'increment count
        i = i + 1

    Loop

    'Print out the 'ThisWorkbook.Sheets(1).Range("A21").Value' line as well
    Debug.Print i + 1, arr(i)
    Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
    Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)


    Exit For


End If

Next

Next

    Debug.Print DateDiff("s", start, Now)

Exit Sub


Err:
    MsgBox "Error while reading the file.", vbCritical, vbNullString
    oFS.Close
    Exit Sub

End Sub

Answer 1

虽然我在这里广泛地查看了你的脚本在做什么。要简单地更改输出表，它应该是这样的。

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



For i = LBound(arr) To UBound(arr)
    If InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A20").Value, vbTextCompare) Then

    'While value in 'ThisWorkbook.Sheets(1).Range("A20").Value' has not been found,
    'keep looping to print out contents starting from 'ThisWorkbook.Sheets(1).Range("A21").Value'
    Do While InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A21").Value, vbTextCompare) = 0

        Debug.Print i + 1,
        '###################
        '#  Added the sheet name to the front of this variable. 
        '#  Make sure there is a third sheet in your workbook!
        '##################
        sheets("Sheet3").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
        sheets("Sheet3").Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)



        'increment count
        i = i + 1

    Loop

        '###################
        '#  Also added the sheet name here 
        '##################
    'Print out the 'ThisWorkbook.Sheets(1).Range("A21").Value' line as well
    Debug.Print i + 1, arr(i)
    sheets("Sheet3").Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
    sheets("Sheet3").Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)


    Exit For


End If

Next

Next

    Debug.Print DateDiff("s", start, Now)

Exit Sub


Err:
    MsgBox "Error while reading the file.", vbCritical, vbNullString
    oFS.Close
    Exit Sub

End Sub

Answer 2

替代：

For i = LBound(arr) To UBound(arr)
    If InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A20").Value, vbTextCompare) Then

    'While value in 'ThisWorkbook.Sheets(1).Range("A20").Value' has not been found,
    'keep looping to print out contents starting from 'ThisWorkbook.Sheets(1).Range("A21").Value'
    Do While InStr(1, arr(i), ThisWorkbook.Sheets(1).Range("A21").Value, vbTextCompare) = 0

        Debug.Print i + 1,
        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
        Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)



        'increment count
        i = i + 1

    Loop

    'Print out the 'ThisWorkbook.Sheets(1).Range("A21").Value' line as well
    Debug.Print i + 1, arr(i)
    Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1) = i + 1
    Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1) = arr(i)


    Exit For


End If

Next

使用：

    Dim sheet1A20 As String
    Dim sheet1A21 As String
    With ThisWorkbook
        sheet1A20 = .Sheets(1).Range("A20").Value
        sheet1A21 = .Sheets(1).Range("A21").Value
        With .Sheets(3)
            For i = LBound(arr) To UBound(arr)
                If InStr(1, arr(i), sheet1A20, vbTextCompare) = 0 Then
                    'While value in 'ThisWorkbook.Sheets(1).Range("A20").Value' has not been found,
                    'keep looping to print out contents starting from 'ThisWorkbook.Sheets(1).Range("A21").Value'
                    Do While InStr(1, arr(i), sheet1A21, vbTextCompare) = 0
                        Debug.Print i + 1
                        .Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(, 2) = Array(i + 1, arr(i))
                        i = i + 1 'increment count
                    Loop
                    'Print out the 'ThisWorkbook.Sheets(1).Range("A21").Value' line as well
                    Debug.Print i + 1, arr(i)
                    .Cells(.Rows.count, 1).End(xlUp).Offset(1).Resize(, 2) = Array(i + 1, arr(i))
                    Exit For
                End If
            Next
        End With
    End With