vba - 创建一个循环，直到脚本使用所有单元格

Question

我真的不知道如何编程，但我已经编译了一些脚本来实现几乎我想要的，但我在最后一步失败了。

该脚本从单元格 B2、工作表 2 中的文件目录中打开一个 .txt 文件，并将其内容复制到 Excel(以及我不关心的记事本)中。

但是，我想要对 120 个文件目录执行此操作。目前，我的脚本仅从单元格 B2 获取目录，B 列中包含其下方的其余 119 个目录，我运行脚本并删除该行并重复，这有点费力。

我只想让脚本自动运行 B 列中的所有 120 个文件。任何帮助表示赞赏!

    Option Explicit

Sub ReadTxtFile()
    Dim start As Date
    start = Now

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

    Dim oFS As Object

   Dim filePath As String


    '''''Assign the Workbook File Name along with its Path

    filePath = Worksheets("Sheet2").Range("B2").Value
 MsgBox Worksheets("Sheet2").Range("B2").Value
    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), "Transmission", vbTextCompare) Then

        'Declare variables for the new output file
        Dim sOutputFileNameAndPath As String
        Dim FN As Integer
        sOutputFileNameAndPath = "C:\Users\nfraser\Documents\test\second.txt"
        FN = FreeFile

        'Open new output file
        Open sOutputFileNameAndPath For Output As #FN


        'While 'end of report' has not been found,
        'keep looping to print out contents starting from 'report'
        Do While InStr(1, arr(i), "Ancillary", vbTextCompare) = 0

            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)

            'Print into new output file
            Print #FN, i + 1 & " " & arr(i)

            'increment count
            i = i + 1

        Loop

        'Print out the 'end of report' 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)

        'Print 'end of report' line into new output file as well
        Print #FN, i + 1 & " " & arr(i)

        'close the new output file
        Close #FN

        'exit the 'For..Next' structure since 'end of report' has been found
        Exit For


    End If

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

您可以添加一个for...each循环，循环遍历当前选择中的所有单元格。这是模式:

Dim cCell as Range
For Each cCell in Selection
    'do stuff
Next cCell

现在，由于您在整个代码中更改了选择，因此必须将一开始的选择存储到另一个变量中，例如originalSelection，然后循环遍历 originalSelection 中的单元格。否则，您的选择将在执行期间发生变化。

将其适应您的代码，我们最终得到以下结果...请注意:我将您的代码分为两个方法 ---ReadTxtFiles 和 copyTo； ReadTxtFile() 子程序太长了。

Option Explicit

Sub ReadTxtFiles()
    Dim start As Date
    start = Now

    Dim oFS As Object
    Dim inputFilePath As String
    Dim outputFilePath As String
    Dim outputDirectory As String
    outputDirectory = "C:\Users\nfraser\Documents\test\"

    '''''Assign the Workbook File Name along with its Path
    Dim originalSelection As Range
    Dim cCell As Range
    Dim i As Integer

    Set originalSelection = Selection

    For Each cCell In originalSelection
        inputFilePath = cCell.Value
        outputFilePath = outputDirectory & i & ".txt"
        copyTo inputFilePath, outputFilePath
    Next cCell

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

End Sub


Sub copyTo(inputPath As String, outputPath As String)
    Dim arr(100000) As String
    Dim i As Long
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject") 'late binding
    Dim oFS As Object
    i = 0

    If oFSO.FileExists(inputPath) Then
        On Error GoTo Err 'ensure oFS gets closed

        Set oFS = oFSO.OpenTextFile(inputPath)

        'read file contents into array
        Do While Not oFS.AtEndOfStream
            arr(i) = oFS.ReadLine
            i = i + 1
        Loop

        'close
        oFS.Close
    Else 'file didn't exist
        MsgBox "The file path is invalid.", vbCritical, vbNullString
        Exit Sub
    End If

    For i = LBound(arr) To UBound(arr)

        If InStr(1, arr(i), "Transmission", vbTextCompare) Then

            'Declare variables for the new output file
            Dim FN As Integer
            FN = FreeFile

            'Open new output file
            Open outputPath For Output As #FN

            'While 'end of report' has not been found,
            'keep looping to print out contents starting from 'report'
            Do While InStr(1, arr(i), "Ancillary", vbTextCompare) = 0

                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)

                'Print into new output file
                Print #FN, i + 1 & " " & arr(i)

                'increment count
                i = i + 1

            Loop

            'Print out the 'end of report' 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)

            'Print 'end of report' line into new output file as well
            Print #FN, i + 1 & " " & arr(i)

            'close the new output file
            Close #FN

            'exit the 'For..Next' structure since 'end of report' has been found
            Exit For
        End If
    Next
    Exit Sub

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