Excel vba：導入多個文本文件，並在導入后移動文件？

Question

我真的希望有人可以提供幫助。 目前，我正在使用vba將文本文件中的每一行文本導入一行中的新列中。 每次我運行該函數時，都會在前一個數據下方創建新的一行數據。

結果：

Row 1 (Showing Data from TextFile 1)
Column A     Column B           Column C
Data         Data               Data

Row 2 (Showing Data from TextFile 2)
Column A     Column B           Column C
Data         Data               Data

這樣，一切正常，當我從文件導入文本后，文件從我的目錄“未操作”移到了“已操作”目錄。

因此，目前我的代碼還不存在，我目前必須定義文本文件名，以便可以將數據從文本文件導入到電子表格中，然后再次定義要移動的文本文件名，該代碼目前僅適用於1個文本文件。 但是我想要做的是，如果我的文件夾“未操作”中有幾個文本文件，那么我想將這些文本文件中的每一個導入到新行中，並移動所有我們剛剛導入數據的文本文件從同時移至我的資料夾

這是我的代碼：

Sub ImportFile()

    Dim rowCount As Long

    rowCount = ActiveSheet.UsedRange.Rows.Count + 1

    If Cells(1, 1).Value = "" Then rowCount = 1


    Close #1
    Open "Y:\Incident Logs\Unactioned\INSC89JH.txt" For Input As #1
    A = 1
     Do While Not EOF(1)
            Line Input #1, TextLine
            Cells(rowCount, A) = TextLine
            A = A + 1
        Loop
    Close #1


 Dim d As String, ext, x
Dim srcPath As String, destPath As String, srcFile As String
srcPath = "Y:\Incident Logs\Unactioned\"
destPath = "Y:\Incident Logs\Actioned\"
ext = Array("*.txt", "*.xls")
For Each x In ext
    d = Dir(srcPath & x)
        Do While d <> ""
            srcFile = srcPath & d
            FileCopy srcFile, destPath & d
            Kill srcFile
            d = Dir
        Loop
Next


End Sub

請有人可以告訴我如何修改此代碼以執行我需要的操作嗎？ 提前致謝

Answer 1

我建議將您的代碼分成多個功能。

您可以更改ImportFile方法以不殺死所有文件，而只是殺死其上運行的文件，然后一次刪除一個特定的文件。 例如：

Sub ImportFile(directory As String, filename As String)
    Dim rowCount As Long
    rowCount = ActiveSheet.UsedRange.Rows.Count + 1
    If Cells(1, 1).Value = "" Then rowCount = 1

    Close #1
    Open directory & filename For Input As #1
    A = 1
     Do While Not EOF(1)
            Line Input #1, TextLine
            Cells(rowCount, A) = TextLine
            A = A + 1
        Loop
    Close #1

    'Move the file and delete it
    Dim srcPath As String, destPath As String
    srcPath = directory & filename
    destPath = "C:\Incident Logs\Actioned\" & filename
    FileCopy srcPath, destPath
    Kill srcPath
End Sub

然后，這是有關如何迭代文件夾中文件的另一個stackoverflow帖子

因此，只需稍作修改，您就可以得到以下內容：

Sub ImportAllFiles()
    ImportFilesWithExtension "*.txt"
    ImportFilesWithExtension "*.xls*"
End Sub

Sub ImportFilesWithExtension(extension As String)
    Dim StrFile As String, myDir As String
    myDir = "C:\Incident Logs\Unactioned\"
    StrFile = Dir(myDir & extension)
    Do While Len(StrFile) > 0
        ImportFile myDir, StrFile
        StrFile = Dir
    Loop
End Sub

Answer 2

我還將其分解為功能：

Sub ImportFile()

    Dim rLastCell As Range
    Dim vFolder As Variant
    Dim vFile As Variant
    Dim colFiles As Collection


    With ThisWorkbook.Worksheets("Sheet1") 'Note - update sheet name.

        'First find the last cell on the named sheet.
        Set rLastCell = .Cells.Find( _
            What:="*", _
            LookIn:=xlValues, _
            SearchDirection:=xlPrevious)

        If rLastCell Is Nothing Then
            'Set LastCell to A2.
            Set rLastCell = .Cells(2, 1)
        Else
            'Set LastCell to column A, last row + 1
            Set rLastCell = .Range(rLastCell.Row + 1, 1)
        End If

        vFolder = GetFolder()
        Set colFiles = New Collection

        EnumerateFiles vFolder, "\*.txt", colFiles

        For Each vFile In colFiles
            'Do stuff with the file.

            'Close the file and move it.
            MoveFile CStr(vFile), "S:\Bartrup-CookD\Text 1\" & Mid(vFile, InStrRev(vFile, "\") + 1, Len(vFile)) 'Note - update folder name.
        Next vFile

    End With

End Sub

這會將所有文件放入集合中：

Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef cCollection As Collection)

    Dim sTemp As String

    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        cCollection.Add sDirectory & "\" & sTemp
        sTemp = Dir$
    Loop
End Sub

這將要求您選擇一個文件夾：

' To Use    : vFolder = GetFolder()
'           : vFolder = GetFolder("S:\Bartrup-CookD\Customer Services Phone Reports")
Function GetFolder(Optional startFolder As Variant = -1) As Variant
    Dim fldr As FileDialog
    Dim vItem As Variant
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If startFolder = -1 Then
            .InitialFileName = Application.DefaultFilePath
        Else
            If Right(startFolder, 1) <> "\" Then
                .InitialFileName = startFolder & "\"
            Else
                .InitialFileName = startFolder
            End If
        End If
        If .Show <> -1 Then GoTo NextCode
        vItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = vItem
    Set fldr = Nothing
End Function

這會將文件從文件夾A移到文件夾B：

'----------------------------------------------------------------------
' MoveFile
'
'   Moves the file from FromFile to ToFile.
'   Returns True if it was successful.
'----------------------------------------------------------------------
Public Function MoveFile(FromFile As String, ToFile As String) As Boolean

    Dim objFSO As Object

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    objFSO.MoveFile FromFile, ToFile
    MoveFile = (Err.Number = 0)
    Err.Clear
End Function