在Excel 2013中合並文本文件

Question

Excel宏的新增功能，因此需要一些幫助。 我在一個目錄中大約有60多個文本文件，每個文本文件只有一列數據。 我正在嘗試獲取/編寫一個將導入所有文本文件的宏，但還會添加第二個包含文件名的列。

我要執行2個步驟。 第一子目錄獲取文件名列表，第二子目錄獲取txt文件的內容。 因此，我要尋找的最終結果是一張工作表，其中A列中的txt內容和B列中的源文件名稱。我正在努力獲取文件名。文件導入必須相互重疊。

Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$

InitialFoldr$ = "C:\Desktop" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    If .SelectedItems.Count <> 0 Then
        xDirect$ = .SelectedItems(1) & "\"
        xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
            ActiveCell.Offset(xRow) = Left(xFname$, InStrRev(xFname$, ".") - 1)
            xRow = xRow + 1
            xFname$ = Dir
            With ActiveSheet.QueryTables.Add(Connection:= _
               "TEXT;" & xFname$, Destination:=Range("$A$1"))
            End With

        Loop
    End If
End With

End Sub

Sub TextContent()

Dim myfiles
Dim i As Integer

myfiles = Application.GetOpenFilename(filefilter:="Text Files (*.txt),    *.txt", MultiSelect:=True)

If Not IsEmpty(myfiles) Then
    For i = LBound(myfiles) To UBound(myfiles)
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End  (xlUp).Offset(1, 0))
            .Name = "Sample"
            .FieldNames = False
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = True
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = True
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    Next i
Else
    MsgBox "No File Selected"
End If

End Sub



Sub FileList()

Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$

InitialFoldr$ = "C:\Desktop" '<<< Startup folder to begin searching from

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = Application.DefaultFilePath & "\"
    .Title = "Please select a folder to list Files from"
    .InitialFileName = InitialFoldr$
    .Show
    If .SelectedItems.Count <> 0 Then
        xDirect$ = .SelectedItems(1) & "\"
        xFname$ = Dir(xDirect$, 7)
        Do While xFname$ <> ""
            ActiveCell.Offset(xRow) = Left(xFname$, InStrRev(xFname$, ".") - 1)
            xRow = xRow + 1
            xFname$ = Dir
            With ActiveSheet.QueryTables.Add(Connection:= _
               "TEXT;" & xFname$, Destination:=Range("$A$1"))
            End With

        Loop
    End If
End With

End Sub

Sub TextContent()

Dim myfiles
Dim i As Integer

myfiles = Application.GetOpenFilename(filefilter:="Text Files (*.txt),   *.txt", MultiSelect:=True)

If Not IsEmpty(myfiles) Then
    For i = LBound(myfiles) To UBound(myfiles)
        With ActiveSheet.QueryTables.Add(Connection:= _
            "TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End  (xlUp).Offset(1, 0))
            .Name = "Sample"
            .FieldNames = False
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = True
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = False
            .TextFileSpaceDelimiter = True
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With
    Next i
Else
    MsgBox "No File Selected"
End If

End Sub

Answer 1

這樣的事情應該做你想要的。

Sub ImportTextFiles()
    Dim myFile As String, text As String, textline As String
    Dim iRow As Long
    Application.ScreenUpdating = False
    For iRow = 1 To Range("B" & Rows.Count).End(xlUp).Row
        ' Reset the text variable
        text = ""
        ' Compose the full path
        myFile = Range("A" & iRow).Value & "\" & Range("B" & iRow).Value
        ' Open the file
        Open myFile For Input As #1
        ' Loop through the lines of the file
        Do Until EOF(1)
            ' Read a line
            Line Input #1, textline
            ' Concatenate text
            text = text & " " & textline
        Loop
        ' Close the file
        Close #1
        ' Write text to cell
        Range("C" & iRow).Value = Mid(text, 2)
    Next iRow
    Application.ScreenUpdating = True
End Sub

可以隨意修改腳本以適合您的特定需求。 請記住，您幾乎可以做任何想做的事...