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

【问题标题】：Automating TXT file import to xls with Specifications in excel or access使用 excel 或 access 中的规范自动将 TXT 文件导入到 xls
【发布时间】：2017-04-21 14:52:59
【问题描述】：

我有大约 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 次。这很奇怪。

我对编码还是有点陌生，所以任何帮助都将不胜感激！

【问题讨论】：

从手动录制宏开始？然后利用循环打开所有文件。
所以当我尝试这个时，我遇到了程序将每个文件作为新工作表直接添加到工作簿的问题，并且文件名和扩展名是我不想要的。我想让他们每个人都有自己的工作簿，工作表保留原始文件名，我不知道该怎么做。

标签： excel vba csv ms-access import

【解决方案1】：

考虑一个 SQL 和 QueryTable 解决方案。使用 ACE 引擎（Windows .dll 文件），您可以查询 csv 文件，特别是运行 SELECT TOP 52 * 以获取顶部摘要行，然后使用 QueryTable 获取从第 53 行开始的底部行（因为 ACE SQL 没有 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

【讨论】：

好吧，我把原来的帖子搞砸了。我的意思是说它们是 .txt 文件，但它们是分隔文本。我会试试这个，看看它是否有效！我想要尝试做的一件事是为循环中每个文件的工作表名称保留原始文件名（不带 .txt），对于具有摘要的工作表，我希望它是“[原始文件名这里]_摘要”。有没有办法做到这一点？
所以在运行这段代码时，我遇到了 2 个问题。首先
所以在运行此代码时，我遇到了 2 个问题 wb.SaveAs strpath & "\" & Replace(strfile, ".csv", ".xlsx"), xlWorkbookDefault 我将 .csv 替换为 . txt 看看这是否可行，因为文件都保存为 .txt 文件......但它不断抛出一个错误代码，说该文件无法访问。其次，在底框函数中，“.Refresh BackgroundQuery:=False”也是在抛出一个错误码... Runtime 1004 error
好的，所以我发现了一个 StackOverflow 问题，有人建议只使用“wb.SaveAs”而不是长路径名，但这只是一遍又一遍地重复第一个文件，并且只添加了它的摘要，而不是逐帧...
txt文件中的分隔符是什么？标签？逗号？分号？是的，它应该是 .csv，但如果您更改为 .txt，不确定为什么会出现错误，这可能与查询表错误有关。请注意 strpath 也在文件名中连接。

【解决方案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

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

【讨论】：