如何将多个文本文件导入单个Excel工作表的列

Question

我一直在尝试找出如何使用数百个制表符分隔的文本文件并将数据导入到单个excel工作表的后续列中。文本文件包含具有两列和标题的I（V）数据。我发现代码/对其进行了操作，使其能够删除标头并导入工作簿中的各个工作表中，但希望能够将每个工作表中的两列数据获取到一个工作表中（即，第一个文本文件中的列一个工作表的A和B列，从第二个文本文件到C和D列的列等）。这是我当前正在使用的代码：

module.exports = {
 'Verify Added customer': function (browser) {
// In above first function with name 'Verify Added customer'
    browser
    .click(rc.registeredCustomers)
    .pause(t.averagePauseLimit)

},

'Verify Email Button Present': function (browser) {
// in above there is second function
    browser
        .click(rc.registeredCustomers)
        .pause(t.averagePauseLimit)
        .getText(rc.primaryEmail, function (result) {
            this.assert.equal(result.value, 'Primary : ' + email)
        })
        .pause(t.minimumPauseLimit)
        .click(rc.verifyCustomer)
        .pause(1000)
        .assert.elementNotPresent(rc.verifyEmail, 'Verify Email is not present')


},

以下是我的I（V）数据文件之一的示例：

Sub CombineTextFiles()
    Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Text Files (*.txt), *.txt", _
      MultiSelect:=True, Title:="Text Files to Open")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    wkbTemp.Sheets(1).Copy
    Set wkbAll = ActiveWorkbook
    wkbTemp.Close (False)
    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
      Destination:=Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, _
      ConsecutiveDelimiter:=False, _
      Tab:=True, Semicolon:=False, _
      Comma:=False, Space:=False, _
      Other:=True, OtherChar:="|"
      Rows("1:20").Select
      Selection.Delete Shift:=xlUp
    x = x + 1

    While x <= UBound(FilesToOpen)
        Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
        With wkbAll
            wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
            .Worksheets(x).Columns("A:A").TextToColumns _
              Destination:=Range("A1"), DataType:=xlDelimited, _
              TextQualifier:=xlDoubleQuote, _
              ConsecutiveDelimiter:=False, _
              Tab:=False, Semicolon:=False, _
              Comma:=False, Space:=False, _
              Other:=True, OtherChar:=sDelimiter
              Rows("1:20").Select
              Selection.Delete Shift:=xlUp
        End With
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
    Set wkbTemp = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

不需要任何标题信息，这就是为什么我目前仅删除前20行的原因。我有基本的编程经验，但对VBA却很少。非常感谢您解决此特定问题！

-Tory

Answer 1

尝试：

Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

sDelimiter = "|"
Set wkbAll = ActiveWorkbook

FilesToOpen = Application.GetOpenFilename _
  (FileFilter:="Text Files (*.txt), *.txt", _
  MultiSelect:=True, Title:="Text Files to Open")

If TypeName(FilesToOpen) = "Boolean" Then
    MsgBox "No Files were selected"
    GoTo ExitHandler
End If

iDestCol=1
For x = 0 to Ubound(FilesToOpen)
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    wkbTemp.Columns("A:A").TextToColumns _
       Destination:=Range("A1"), DataType:=xlDelimited, _
       TextQualifier:=xlDoubleQuote, _
       ConsecutiveDelimiter:=False, _
       Tab:=True, Semicolon:=False, _
       Comma:=False, Space:=False, _
       Other:=True, OtherChar:="|"
    wbkTemp.Range("A:B").Copy Destination:=wkbAll.Cells(1, iDestCol)
    wkbTemp.Close (False)
    iDestCol = iDestCol + 2
  Next

  Rows("1:20").Delete Shift:=xlUp

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Answer 2

因此，我设法将两个宏进行了编码以执行所需的操作。我有一个用于将所选文本文件中的数据提取到单个工作表中，另一个用于将工作表合并为单个工作表的列。第一个宏的代码在这里：

Sub TextToSheets()
 Dim FilesToOpen
    Dim x As Integer
    Dim wkbAll As Workbook
    Dim wkbTemp As Workbook
    Dim sDelimiter As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    sDelimiter = "|"

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="Text Files (*.txt), *.txt", _
      MultiSelect:=True, Title:="Text Files to Open")

    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "No Files were selected"
        GoTo ExitHandler
    End If

    x = 1
    Name = Dir(FilesToOpen(x))
    Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
    wkbTemp.Sheets(1).Copy
    Set wkbAll = ActiveWorkbook
    wkbTemp.Close (False)
    wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
      Destination:=Range("A1"), DataType:=xlDelimited, _
      TextQualifier:=xlDoubleQuote, _
      ConsecutiveDelimiter:=False, _
      Tab:=True, Semicolon:=False, _
      Comma:=False, Space:=False, _
      Other:=True, OtherChar:="|"
      Range("A19:B19").Select
      ActiveCell.FormulaR1C1 = Name
      Range("A20").Select
      ActiveCell.FormulaR1C1 = "Voltage (V)"
      Range("B20").Select
      ActiveCell.FormulaR1C1 = "Current (A)"
      Rows("1:18").Select
      Selection.Delete Shift:=xlUp

    x = x + 1

    While x <= UBound(FilesToOpen)
        Name = Dir(FilesToOpen(x))
        Set wkbTemp = Workbooks.Open(Filename:=FilesToOpen(x))
        With wkbAll
            wkbTemp.Sheets(1).Move after:=.Sheets(.Sheets.Count)
            .Worksheets(x).Columns("A:A").TextToColumns _
              Destination:=Range("A1"), DataType:=xlDelimited, _
              TextQualifier:=xlDoubleQuote, _
              ConsecutiveDelimiter:=False, _
              Tab:=False, Semicolon:=False, _
              Comma:=False, Space:=False, _
              Other:=True, OtherChar:=sDelimiter
              Range("A19:B19").Select
              ActiveCell.FormulaR1C1 = Name
              Range("A20").Select
              ActiveCell.FormulaR1C1 = "Voltage (V)"
              Range("B20").Select
              ActiveCell.FormulaR1C1 = "Current (A)"
              Rows("1:18").Select
              Selection.Delete Shift:=xlUp
        End With
        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Set wkbAll = Nothing
    Set wkbTemp = Nothing
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

这里是第二个：

Sub CombineSheetsToColumns()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Summary").Delete
Application.DisplayAlerts = True
n = Application.Worksheets.Count
Sheets.Add.Name = "Summary"
Sheets("Summary").Move after:=Worksheets(Worksheets.Count)
Set MerPos = Range(Cells(1, 2), Cells(1, 3))

Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Summary" And sh.Name <> Sheets(n + 1).Name Then
Set col = Columns(Columns.Count).End(xlToLeft)
    sh.Range("A:A,B:B").Copy Destination:=Sheets("Summary").Range(col, col).Offset(0, 1)
    MerPos.Select
    Selection.Merge
    Set MerPos = Range(MerPos.Offset(0, 1), MerPos.Offset(0, 2))
End If
Next sh
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

Sheets("Summary").Select
Cells.HorizontalAlignment = xlCenter
Columns.AutoFit = xlColumn
End Sub

我添加了几行来添加文本和格式设置，但是让它适用于您可能需要使用的任何内容都应该很容易。感谢您的所有帮助！

Answer 3

如果您想跨工作表复制/粘贴数据，请运行下面的代码。

Sub ReadFilesIntoActiveSheet()

Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range

' Get a FileSystem object
Set fso = New FileSystemObject

' get the directory you want
Set folder = fso.GetFolder("C:\Users\Excel\Desktop\Coding\LinkedIn\Import All Text Files Into One Single Sheet with File Name in Column A\")

' set the starting point to write the data to
'Set cl = ActiveSheet.Cells(1, 1)
Dim sht As Worksheet
Dim LastRow As Long

Set sh = ActiveSheet

' Loop thru all files in the folder
For Each file In folder.Files
    ' Write file-name
    LastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row + 1
    Range("A" & LastRow).Select
    ActiveCell = file.Name

    ' open the file
    Set txtFile = fso.OpenTextFile(file)

    col = 2
    Do While Not txtFile.AtEndOfStream
        dat = Application.Transpose(Application.Index(Split(txtFile.ReadLine, ","), 1, 0))
        sh.Cells(LastRow, col).Resize(UBound(dat), 1) = dat
        col = col + 1
    Loop

    ' Clean up
    txtFile.Close
    'Range(cl.Address).Offset(1, 0).Select
Next file

Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing

End Sub

如果要将数据复制/粘贴到一张纸上，请运行下面的代码。

Sub ReadFilesIntoActiveSheet()

Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range

' Get a FileSystem object
Set fso = New FileSystemObject

' get the directory you want
Set folder = fso.GetFolder("C:\Users\Excel\Desktop\Coding\LinkedIn\Import All Text Files Into One Single Sheet with File Name in Column A\")

' set the starting point to write the data to
Set cl = ActiveSheet.Cells(2, 1)

' Loop thru all files in the folder
For Each file In folder.Files
    ' Write file-name
    cl.Value = file.Name

    ' Open the file
    Set FileText = file.OpenAsTextStream(ForReading)

    ' Read the file one line at a time
    Do While Not FileText.AtEndOfStream
        TextLine = FileText.ReadLine

        ' Parse the line into | delimited pieces
        Items = Split(TextLine, "|")

        ' Put data on one row in active sheet
        For i = 0 To UBound(Items)
            cl.Offset(0, 1 + i).Value = Items(i)
        Next

        ' Move to next row
        Set cl = cl.Offset(1, 0)
    Loop

    ' Clean up
    FileText.Close
Next file

Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing

End Sub