自动将TXT文件导入到xls，并在excel或access中进行规范

Question

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

我正在寻找一种方法来：

1）打开CSV文件

2）保存汇总数据与文件名 “Original_Summary”

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

以前，我已经用〜124个文件手工完成了每个文件的剪切/粘贴操作，但由于文件数量太多了，我不确定手动操作是否是最好的选择。

我有另一个脚本，我已经写入，将这些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个左右，也不会将其导入到一个新的工作簿，而只能用一个新的工作表原来的扩展。出于某种原因，它也只能工作1次，然后才能删除文件并重新开始。这很奇怪。

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

Answer 1

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

下面设置功能两者的顶部和底部带有宏观creatig工作簿和工作表，然后调用在一个循环中这些方法：

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 

我唯一担心的是，这可能会使用大量的资源。希望它不会，但在我测试过的几个文件上，它工作正常！