Как импортировать несколько текстовых файлов в столбцы одного листа Excel - PullRequest
Новая
       11

Как импортировать несколько текстовых файлов в столбцы одного листа Excel

0 голосов
/ 15 октября 2018

Я пытался выяснить, как взять несколько сотен текстовых файлов с разделителями табуляции и импортировать данные в последующие столбцы одной таблицы 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

Ответы [ 3 ]

0 голосов
/ 16 октября 2018

Итак, мне удалось запрограммировать два макроса, чтобы сделать то, что мне нужно.У меня есть один для извлечения данных из выбранных текстовых файлов на отдельные листы, а другой - для объединения листов в столбцы одного листа.Код для первого макроса здесь: 

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

Я добавил несколько строк для добавления текста и форматирования, но это не должно быть слишком сложночтобы заставить его работать на все, что вам может понадобиться.Спасибо за помощь!

0 голосов
/ 27 октября 2018

Если вы хотите скопировать / вставить данные на лист, запустите приведенный ниже код. 

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
0 голосов
/ 15 октября 2018

Попробуй так: 

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
...