使用excel或access中的规范自动将TXT文件导入到xls

我有约900个CSV文件，所有这些都是从跟踪软件导出的。 不幸的是，这个软件根据帧数据input大约52行左右的总结数据，这些数据有许多标题。

我正在寻找的是一种方法：

1）打开csv文件

2）将摘要数据保存为单独的电子表格，文件名为“Original_Summary”

3）将逐帧数据（包含标题）保存到单独的Excel文件中，原始文件名称作为工作表的新名称。

以前，我已经用〜124个文件手动完成了这个剪切/粘贴操作，但是由于文件数量已经非常多，所以我不确定手动这样做是最好的select。

我有另一个脚本，我已经写入，将这些excel文件作为单独的表格导入到Access中，但是现在我需要一种方法将它们从CSV中传输，并将顶部的所有额外摘要数据移动到单独的文件中。

有没有办法可以做到这一点？

谢谢！

Sub ImportManyTXTs_test() Dim strFile As String Dim foldername As String Dim ws As Worksheet strFile = Dir("C:\Users\Jared\Desktop\Processed\Text\*.txt") Do While strFile <> vbNullString Set ws = Sheets.Add With ws.QueryTables.Add(Connection:= _ "TEXT;" & "C:\Users\Jared\Desktop\Processed\Text\" & strFile, Destination:=Range("$A$1")) .Name = strFile '.FieldNames = True '.RowNumbers = False '.FillAdjacentFormulas = False '.PreserveFormatting = True '.RefreshOnFileOpen = False '.RefreshStyle = xlInsertDeleteCells '.SavePassword = False '.SaveData = True '.AdjustColumnWidth = True '.RefreshPeriod = 0 '.TextFilePromptOnRefresh = False '.TextFilePlatform = 437 '.TextFileStartRow = 52 '.TextFileParseType = xlFixedWidth '.TextFileTextQualifier = xlTextQualifierDoubleQuote '.TextFileConsecutiveDelimiter = False '.TextFileTabDelimiter = False '.TextFileSemicolonDelimiter = False '.TextFileCommaDelimiter = False '.TextFileSpaceDelimiter = False '.TextFileColumnDataTypes = Array(xlYMDFormat, 1, 1) '.TextFileFixedColumnWidths = Array(22, 13, 13) '.TextFileTrailingMinusNumbers = True '.Refresh BackgroundQuery:=False '.CommandType = 0 '.Name = "T15_070916_B" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 437 .TextFileStartRow = 52 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With ActiveSheet.Name = strFile strFile = Dir Loop End Sub 

我已经试过了，它似乎没有上传我的所有文件，只有前99个左右，也不会将它们导入到新的工作簿，而只是一个新的原始扩展名工作表。 出于某种原因，它也只能工作一次，然后才能删除文件并重新开始。 这很奇怪。

我还是一个新的编码，所以任何帮助，将不胜感激！

Answer 1

考虑一个SQL和QueryTable解决scheme。 使用ACE引擎（Windows .dll文件），您可以查询csv文件，特别是对顶部汇总行运行SELECT TOP 52 * ，然后对行53开始的底部行使用QueryTable（因为ACE SQL不具有BOTTOM谓词）。

下面用一个macros创build一个工作簿和工作表，为Top和Bottom部分设置函数，然后在一个循环中调用这些方法：

 Sub ExtractCSV() Dim wb As Workbook Dim strfile As String, strpath As String strpath = "C:\Users\Jared\Desktop\Processed\Text\" strfile = Dir("C:\Users\Jared\Desktop\Processed\Text\*.txt") Do While strfile <> vbNullString Set wb = Workbooks.Add() wb.Sheets(1).Name = "Original Summary" wb.Sheets.Add After:=wb.Sheets(wb.Worksheets.Count) wb.Sheets(2).Name = "Frame" Call TopSummary(wb, strpath, strfile) Call BottomFrame(wb, strpath, strfile) wb.SaveAs strpath & "\" & Replace(strfile, ".csv", ".xlsx"), xlWorkbookDefault wb.Close True strfile = Dir Loop Set wb = Nothing End Sub Function TopSummary(currwb As Workbook, strpath As String, strfile As String) Dim conn As Object, rst As Object Dim strConnection As String, strSQL As String Dim i As Integer Set conn = CreateObject("ADODB.Connection") Set rst = CreateObject("ADODB.Recordset") ' CONNECTION STRING strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ & "Data Source=" & strpath & ";" _ & "Extended Properties=""text;HDR=Yes;FMT=Delimited;""" ' OPEN DB CONNECTION conn.Open strConnection ' QUERY CSV strSQL = " SELECT TOP 52 * FROM " & strfile ' OPEN QUERY RECORDSET rst.Open strSQL, conn currwb.Sheets(1).Range("A2").CopyFromRecordset rst currwb.Sheets(1).Range("A:A").TextToColumns DataType:=xlDelimited, _ ConsecutiveDelimiter:=False, Tab:=True rst.Close: conn.Close Set rst = Nothing: Set conn = Nothing End Function Function BottomFrame(currwb As Workbook, strpath As String, strfile As String) Dim qt As QueryTable ' ADD QUERYTABLE With currwb.Sheets(2).QueryTables.Add(Connection:="TEXT;" & strpath & "\" & strfile, _ Destination:=currwb.Sheets(2).Cells(1, 1)) .TextFileStartRow = 53 .TextFileParseType = xlDelimited .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .Refresh BackgroundQuery:=False End With ' REMOVE QUERYTABLE For Each qt In currwb.Sheets(2).QueryTables qt.Delete Next qt Set qt = Nothing End Function 

Answer 2

感谢@Parfait，我能够开发一些代码来做我想做的事情。

  Sub ExtractCSV() Dim wb As Workbook Dim y As Workbook Dim strfile As String, strpath As String 'Adjust the line below to have the appropriate folder directory, changing from new folder to something strpath = "C:\Users\me\Desktop\Processed\Text\" strfile = Dir("C:\Users\me\Desktop\Processed\Text\*.txt") Do While strfile <> vbNullString Workbooks.OpenText Filename:=strpath & strfile, Origin:= _ 437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _ Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _ Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array( _ 16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), _ Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array( _ 29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), _ Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array( _ 42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), _ Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array( _ 55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), _ Array(62, 1), Array(63, 1), Array(64, 1), Array(65, 1), Array(66, 1), Array(67, 1), Array( _ 68, 1), Array(69, 1), Array(70, 1), Array(71, 1), Array(72, 1), Array(73, 1), Array(74, 1), _ Array(75, 1), Array(76, 1), Array(77, 1)), TrailingMinusNumbers:=True Set y = ActiveWorkbook 'Adjust the line below to have the appropriate folder directory, changing from new folder to something ActiveWorkbook.SaveAs Filename:= _ "C:\Users\me\Desktop\New folder\todelete\" & strfile, FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False Set wb = Workbooks.Add() wb.Sheets(1).Name = Left(strfile, Len(strfile) - 4) wb.Sheets.Add After:=wb.Sheets(wb.Worksheets.Count) wb.Sheets(2).Name = Left(strfile, Len(strfile) - 4) & "_Original_Summary" y.Sheets(Left(strfile, Len(strfile) - 4)).Rows("1:51").Copy 'y.Sheets(Left(strfile, Len(strfile) - 4)).Selection.Copy wb.Sheets(Left(strfile, Len(strfile) - 4) & "_Original_Summary").Range("A1").PasteSpecial y.Sheets(Left(strfile, Len(strfile) - 4)).Rows("52:1600").Copy 'y.Sheets(Left(strfile, Len(strfile) - 4)).Selection.Copy wb.Sheets(Left(strfile, Len(strfile) - 4)).Range("A1").PasteSpecial y.Application.CutCopyMode = False y.Close True 'Call TopSummary(wb, strpath, strfile) 'Call BottomFrame(wb, strpath, strfile) 'wb.SaveAs strpath & "\" & Replace(strfile, ".txt", ".xlsx"), xlWorkbookDefault wb.SaveAs Filename:="C:\Users\me\Desktop\New folder\" & Left(strfile, Len(strfile) - 4) & ".xlsx" wb.Close True strfile = Dir Loop Set wb = Nothing End Sub 

我唯一担心的是这可能会占用大量的资源。 希望它不，但在我testing了这几个文件，它的工作！