我一直在试图弄清楚如何采用几百个制表符分隔的文本文件,并将数据导入到单个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
试试这样:
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
所以,我设法得到两个宏编码来做我需要的。我有一个用于将所选文本文件中的数据拉入单个工作表,另一个用于将工作表合并到单个工作表的列中。第一个宏的代码在这里:
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
我添加了一些用于添加文本和格式的行,但不应该太难以使它适用于您可能需要使用它的任何内容。感谢您的帮助!
如果要在工作表中复制/粘贴数据,请运行以下代码。
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