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

Question

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

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

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

    Notes: 

Timestamp: 7/19/2018 8:36:11 AM

Channel: Channel A

NPLC: 1

Current Limit: 0.010000

Pulse Mode: 0

Bias Pulses: 1

Bias Level: 0.000000

Settling Time: 0.500000

Voltage (V) Current (A)

-1.00000E+0 -6.95885E-7
-9.50000E-1 -6.47828E-7
-9.00000E-1 -6.06955E-7
-8.50000E-1 -5.53913E-7
-8.00000E-1 -5.00038E-7
-7.50000E-1 -4.51646E-7
-7.00000E-1 -4.02903E-7
-6.50000E-1 -3.58851E-7
-6.00000E-1 -3.19926E-7
-5.50000E-1 -2.73332E-7
-5.00000E-1 -2.33349E-7
-4.50000E-1 -1.99018E-7
-4.00000E-1 -1.62825E-7
-3.50000E-1 -1.31703E-7
-3.00000E-1 -1.04510E-7
-2.50000E-1 -8.06238E-8
-2.00000E-1 -5.88286E-8
-1.50000E-1 -4.14340E-8
-1.00000E-1 -2.58151E-8
-5.00000E-2 -1.24138E-8
0.00000E+0  5.52116E-11
5.00000E-2  1.26769E-8
1.00000E-1  2.64685E-8
1.50000E-1  4.17401E-8
2.00000E-1  5.97095E-8
2.50000E-1  7.98343E-8
3.00000E-1  1.02119E-7
3.50000E-1  1.28176E-7
4.00000E-1  1.57270E-7
4.50000E-1  1.89915E-7
5.00000E-1  2.29916E-7
5.50000E-1  2.72104E-7
6.00000E-1  3.35173E-7
6.50000E-1  4.53464E-7
7.00000E-1  6.12379E-7
7.50000E-1  7.97423E-7
8.00000E-1  9.75624E-7
8.50000E-1  1.16841E-6
9.00000E-1  1.34435E-6
9.50000E-1  1.52710E-6
1.00000E+0  1.75166E-6
1.00000E+0  1.81262E-6
9.50000E-1  1.72918E-6
9.00000E-1  1.63206E-6
8.50000E-1  1.52714E-6
8.00000E-1  1.42523E-6
7.50000E-1  1.32162E-6
7.00000E-1  1.21624E-6
6.50000E-1  1.11347E-6
6.00000E-1  1.00770E-6
5.50000E-1  9.05824E-7
5.00000E-1  8.08058E-7
4.50000E-1  7.09499E-7
4.00000E-1  6.14927E-7
3.50000E-1  5.26256E-7
3.00000E-1  4.38557E-7
2.50000E-1  3.53943E-7
2.00000E-1  2.74731E-7
1.50000E-1  1.98096E-7
1.00000E-1  1.27457E-7
5.00000E-2  6.16247E-8
0.00000E+0  -8.63841E-11
-5.00000E-2 -5.78634E-8
-1.00000E-1 -1.15769E-7
-1.50000E-1 -1.73858E-7
-2.00000E-1 -2.33503E-7
-2.50000E-1 -2.94364E-7
-3.00000E-1 -3.59336E-7
-3.50000E-1 -4.24816E-7
-4.00000E-1 -4.92460E-7
-4.50000E-1 -5.61514E-7
-5.00000E-1 -6.32542E-7
-5.50000E-1 -7.06702E-7
-6.00000E-1 -7.83559E-7
-6.50000E-1 -8.63077E-7
-7.00000E-1 -9.49685E-7
-7.50000E-1 -1.03839E-6
-8.00000E-1 -1.12932E-6
-8.50000E-1 -1.22503E-6
-9.00000E-1 -1.31770E-6
-9.50000E-1 -1.42892E-6
-1.00000E+0 -1.53654E-6

不需要任何标题信息，这就是为什么我目前仅删除前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