Vba将hugh csv文件的子部分导入excel 2010

Question

我有一个包含大约 600 个字段和大约 100k 行的 csv 文件，我想仅将选定字段和某些特定行导入其中一组选定字段与一组特定条件匹配的现有 Excel 工作表选项卡

我尝试在 excel 中使用 ms 查询，但它停止在 255 列，我可以在 excel 2010 (250m) 中导入整个文件，但它是一个内存猪，当我删除不需要的字段和行时它锁定了我的电脑。

我想使用 excel vba 宏启动导入过程。我有文件选择等的所有前端代码。但是在文本读取查询转换为vba的excel区域需要一些帮助

任何帮助将不胜感激

谢谢

汤姆

Answer 1

对于这么多记录，您最好将 .csv 导入 Microsoft Access，为某些字段编制索引，编写仅包含所需内容的查询，然后从查询中导出到 Excel。

如果您确实需要仅 Excel 的解决方案，请执行以下操作：

1. 打开 VBA 编辑器。导航到工具 -> 参考。选择最新的 ActiveX 数据对象库。 （简称 ADO）。在我运行 Excel 2003 的 XP 机器上，它是 2.8 版。

2. 如果您还没有模块，请创建一个模块。或者创建一个以包含本文底部的代码。

3. 在任何空白工作表中，从单元格 A1 开始粘贴以下值：

选择字段 1、字段 2 FROM C:\Path\To\file.csv WHERE Field1 = 'foo' 按字段排序2

（此处的格式问题。select from 等应在 A 列中各自的行中以供参考。其他内容是重要的部分，应在 B 列中。）

根据您的文件名和查询要求修改输入字段，然后运行getCsv() 子例程。它会将结果放入从单元格 C6 开始的 QueryTable 对象中。

我个人讨厌 QueryTables，但我更喜欢与 ADO 一起使用的 .CopyFromRecordset 方法不会为您提供字段名称。我留下了该方法的代码，注释掉了，所以你可以用这种方式进行调查。如果你使用它，你可以摆脱对deleteQueryTables() 的调用，因为它是一个非常丑陋的黑客，它会删除你可能不喜欢的整列，等等。

编码愉快。

Option Explicit
Function ExtractFileName(filespec) As String
'   Returns a filename from a filespec
    Dim x As Variant
    x = Split(filespec, Application.PathSeparator)
    ExtractFileName = x(UBound(x))
End Function
Function ExtractPathName(filespec) As String
'   Returns the path from a filespec
    Dim x As Variant
    x = Split(filespec, Application.PathSeparator)
    ReDim Preserve x(0 To UBound(x) - 1)
    ExtractPathName = Join(x, Application.PathSeparator) & Application.PathSeparator
End Function
Sub getCsv()
    Dim cnCsv As New ADODB.Connection
    Dim rsCsv As New ADODB.Recordset
    Dim strFileName As String
    Dim strSelect As String
    Dim strWhere As String
    Dim strOrderBy As String
    Dim strSql As String
    Dim qtData As QueryTable

    strSelect = ActiveSheet.Range("B1").Value
    strFileName = ActiveSheet.Range("B2").Value
    strWhere = ActiveSheet.Range("B3").Value
    strOrderBy = ActiveSheet.Range("B4").Value

    strSql = "SELECT " & strSelect
    strSql = strSql & vbCrLf & "FROM " & ExtractFileName(strFileName)
    If strWhere <> "" Then strSql = strSql & vbCrLf & "WHERE " & strWhere
    If strOrderBy <> "" Then strSql = strSql & vbCrLf & "ORDER BY " & strOrderBy

    With cnCsv
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=" & ExtractPathName(strFileName) & ";" & _
            "Extended Properties=""text;HDR=yes;FMT=Delimited(,)"";Persist Security Info=False"
        .Open
    End With

    rsCsv.Open strSql, cnCsv, adOpenForwardOnly, adLockReadOnly, adCmdText
    'ActiveSheet.Range("C6").CopyFromRecordset rsCsv

    Call deleteQueryTables
    Set qtData = ActiveSheet.QueryTables.Add(rsCsv, ActiveSheet.Range("C6"))
    qtData.Refresh

    rsCsv.Close
    Set rsCsv = Nothing
    cnCsv.Close
    Set cnCsv = Nothing
End Sub
Sub deleteQueryTables()
    On Error Resume Next
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Dim qt As QueryTable
    Dim qtName As String
    Dim nName As Name
    For Each qt In ActiveSheet.QueryTables
        qtName = qt.Name
        qt.Delete
        For Each nName In Names
            If InStr(1, nName.Name, qtName) > 0 Then
                Range(nName.Name).EntireColumn.Delete
                nName.Delete
            End If
        Next nName
    Next qt

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Answer 2

您可以解析输入文件以提取符合您的标准的行。以下代码在 CSV 文件的每一行上使用 split 函数来分隔字段，然后检查它是否符合所需的条件。如果所有条件都匹配，则所选字段将保存在新的 CSV 文件中，然后您可以打开较小的文件。您需要在 VBA 编辑器中设置 microsoft 脚本运行时引用才能使其正常工作。

这种方法应该使用很少的内存，因为它一次处理 1 行，我在 600 个字段和 100000 行的数据上对其进行了测试，处理文件大约需要 45 秒，Windows 任务管理器中的 RAM 使用量没有明显增加.它是 CPU 密集型的，所用时间会随着复杂数据、条件和复制字段数量的增加而增加。

如果您更喜欢直接写入现有工作表，这很容易实现，但您必须先删除那里的所有旧数据。

Sub Extract()

Dim fileHandleInput As Scripting.TextStream
Dim fileHandleExtract As Scripting.TextStream
Dim fsoObject As Scripting.FileSystemObject
Dim sPath As String
Dim sFilenameExtract As String
Dim sFilenameInput As String
Dim myVariant As Variant
Dim bParse As Boolean   'To check if the line should be written

sFilenameExtract = "Exctract1.CSV"
sFilenameInput = "Input.CSV"

Set fsoObject = New FileSystemObject

sPath = ThisWorkbook.Path & "\"

'Check if this works ie overwrites existing file
If fsoObject.FileExists(sPath & sFilenameExtract) Then
    Set fileHandleExtract = fsoObject.OpenTextFile(sPath & sFilenameExtract, ForWriting)
Else
    Set fileHandleExtract = fsoObject.CreateTextFile((sPath & sFilenameExtract), True)
End If

Set fileHandleInput = fsoObject.OpenTextFile(sPath & sFilenameInput, ForReading)


'extracting headers for selected fields in this case the 1st, 2nd and 124th fields
myVariant = Split(fileHandleInput.ReadLine, ",")
fileHandleExtract.WriteLine (myVariant(0) & "," & _
                             myVariant(1) & "," & _
                             myVariant(123))

'Parse each line (row) of the inputfile
Do While Not fileHandleInput.AtEndOfStream
    myVariant = Split(fileHandleInput.ReadLine, ",")

    'Set bParse initially to true
    bParse = True

    'Check if the first element is greater than 123
    If Not myVariant(0) > 123 Then bParse = False

    'Check if second element is one of allowed values
    'Trim used to remove pesky leading or lagging values when checking
    Select Case Trim(myVariant(1))

    Case "Red", "Yellow", "Green", "Blue", "Black"
    'Do nothing as value found

    Case Else
        bParse = False  'As wasn't a value in the condition
    End Select

    'If the conditions were met by the line then write specific fields to extract file
    If bParse Then
        fileHandleExtract.WriteLine (myVariant(0) & "," & _
                                     myVariant(1) & "," & _
                                     myVariant(123))
    End If

Loop

'close files and cleanup
fileHandleExtract.Close
fileHandleInput.Close

Set fileHandleExtract = Nothing
Set fileHandleInput = Nothing
Set fsoObject = Nothing

End Sub