Question

Excel宏的新功能需要一些帮助。我在一个目录中有大约60多个文本文件，每个文件只有一列数据。我正在尝试获取/编写一个宏，它将导入所有文本文件，但也添加包含文件名的第二列。

我正在尝试做两个步骤。 First Sub获取文件名列表，第二个子获取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

随意修改脚本以满足您的特定需求。请记住，你可以做任何你想做的事情......

合并Excel 2013中的文本文件

1 个答案: