excel - 使用 ADO 将 Excel 电子表格导入数组的更快方法

Question

我正在尝试使用 Excel 2007 VBA 将大型 Excel 报告中的数据导入和排序到一个新文件中。到目前为止，我已经提出了两种方法来做到这一点:

让 Excel 实际打开文件(下面的代码)，将所有数据收集到数组中，然后将数组输出到同一文件中的新工作表上，然后保存/关闭它。

 Public Sub GetData()

     Dim FilePath As String

     FilePath = "D:\File_Test.xlsx"
     Workbooks.OpenText Filename:=FilePath, FieldInfo:=Array(Array(2, 2))
     ActiveWorkbook.Sheets(1).Select

 End Sub

使用 ADO 从关闭的工作簿中获取所有数据，将整个数据表导入数组(下面的代码)并从那里对数据进行排序，然后将数据输出到新的工作簿中并保存/关闭它。

 Private Sub PopArray() 'Uses ADO to populate an array that will be used to sort data
     Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
     Dim Getvalue, SourceRange, SourceFile, dbConnectionString  As String

     SourceFile = "D:\File_Test.xlsx"
     SourceRange = "B1:Z180000"

     dbConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
     "Data Source=" & SourceFile & ";" & _
     "Extended Properties=""Excel 12.0 Xml;HDR=No"";"
     Set dbConnection = New ADODB.Connection
     dbConnection.Open dbConnectionString 'open the database connection

     Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")
     Arr = rs.GetRows

     UpBound = UBound(Arr, 2)
     rs.Close
 End Sub

使用的测试文件有大约 65000 条记录需要整理(大约是我最终使用它的三分之一)。当 ADO 版本的性能只比打开的工作表稍微好一点(~44 秒对~40 秒的运行时间)时，我有点失望。我想知道是否有某种方法可以改进 ADO 导入方法(或完全不同的方法 - 可能是 ExecuteExcel4Macro？ - 如果有的话)可以提高我的速度。我唯一能想到的是我正在使用 "B1:Z180000"作为我的SourceRange作为最大范围，然后通过设置 Arr = rs.GetRows 截断准确反射(reflect)记录总数。如果这是导致速度变慢的原因，我不确定如何查找工作表中有多少行。

编辑 - 我正在使用 Range("A1:A"& i) = (Array) 将数据插入到新工作表中。

Answer 1

这个答案可能不是你想要的，但我仍然觉得有必要根据你的附注 [...] 或完全不同的方法 ]...] 发布它。

在这里，我正在处理 200MB(或更多)的文件，每个文件都只是包含分隔符的文本文件。我不再将它们加载到 Excel 中。我也有 Excel 太慢需要加载整个文件的问题。然而，Excel 使用 Open 打开这些文件的速度非常快。方法:

Open strFileNameAndPath For Input Access Read Lock Read As #intPointer

在这种情况下，Excel 不会加载整个文件，而只是逐行读取。因此，Excel 已经可以处理数据(转发它)，然后抓取下一行数据。像这个 Excel 不需要内存来加载 200MB。

使用这种方法，我将数据加载到本地安装的 SQL 中，该 SQL 将数据直接传输到我们的 DWH(也是 SQL)。为了加快使用上述方法的传输速度并将数据快速传输到 SQL 服务器中，我将数据以 1000 行的 block 的形式传输。 Excel 中的字符串变量最多可容纳 20 亿个字符。所以，那里没有问题。

有人可能想知道，如果我已经在使用本地安装的 SQL，为什么我不简单地使用 SSIS。然而，问题是我不再是加载所有这些文件的人了。使用 Excel 生成这个“导入工具”使我能够将这些工具转发给其他人，他们现在正在为我上传所有这些文件。让他们所有人访问 SSIS 既不是一种选择，也不是使用一个可以放置这些文件的指定网络驱动器的可能性，并且 SSIS 会自动加载它们(每 10 分钟左右)。

最后我的代码看起来像这样。

Set conRCServer = New ADODB.Connection
conRCServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
    & "DATA SOURCE=" & Ref.Range("C2").Value2 & ";" _
    & "INITIAL CATALOG=" & Ref.Range("C4").Value & ";" _
    & "Integrated Security=SSPI "
On Error GoTo SQL_ConnectionError
conRCServer.Open
On Error GoTo 0

'Save the name of the current file
strCurrentFile = ActiveWorkbook.Name

'Prepare a dialog box for the user to pick a file and show it
'   ...if no file has been selected then exit
'   ...otherwise parse the selection into it's path and the name of the file
Call Application.FileDialog(msoFileDialogOpen).Filters.Clear
Call Application.FileDialog(msoFileDialogOpen).Filters.Add("Extracts", "*.csv")
Application.FileDialog(msoFileDialogOpen).Title = "Select ONE Extract to import..."
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
If intChoice <> 0 Then
    strFileToPatch = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Else
    Exit Sub
End If

'Open the Extract for import and close it afterwards
intPointer = FreeFile()
Open strFileNameAndPath For Input Access Read Lock Read As #intPointer

intCounter = 0
strSQL = vbNullString
Do Until EOF(intPointer)
    Line Input #intPointer, strLine
    If Left(strLine, 4) = """@@@" Then Exit Sub
    '*********************************************************************
    '** Starting a new SQL command
    '*********************************************************************
    If intCounter = 0 Then
        Set rstResult = New ADODB.Recordset
        strSQL = "set nocount on; "
        strSQL = strSQL & "insert into dbo.tblTMP "
        strSQL = strSQL & "values "
    End If
    '*********************************************************************
    '** Transcribe the current line into SQL
    '*********************************************************************
    varArray = Split(strLine, ",")
    strSQL = strSQL & " (" & varArray(0) & ", " & varArray(1) & ", N'" & varArray(2) & "', "
    strSQL = strSQL & " N'" & varArray(3) & "', N'" & varArray(4) & "', N'" & varArray(5) & "', "
    strSQL = strSQL & " N'" & varArray(6) & "', " & varArray(8) & ", N'" & varArray(9) & "', "
    strSQL = strSQL & " N'" & varArray(10) & "', N'" & varArray(11) & "', N'" & varArray(12) & "', "
    strSQL = strSQL & " N'" & varArray(13) & "', N'" & varArray(14) & "', N'" & varArray(15) & "' ), "
    '*********************************************************************
    '** Execute the SQL command in bulks of 1.000
    '*********************************************************************
    If intCounter >= 1000 Then
        strSQL = Mid(strSQL, 1, Len(strSQL) - 2)
        rstResult.ActiveConnection = conRCServer
        On Error GoTo SQL_StatementError
        rstResult.Open strSQL
        On Error GoTo 0
        If Not rstResult.EOF And Not rstResult.BOF Then
            strErrorMessage = "The server returned the following error message(s):" & Chr(10)
            While Not rstResult.EOF And Not rstResult.BOF
                strErrorMessage = Chr(10) & strErrorMessage & rstResult.Fields(0).Value
                rstResult.MoveNext
            Wend
            MsgBox strErrorMessage & Chr(10) & Chr(10) & "Aborting..."
            Exit Sub
        End If
    End If
    intCounter = intCounter + 1
Loop

Close intPointer

Set rstResult = Nothing

Exit Sub

SQL_ConnectionError:
Y = MsgBox("Couldn't connect to the server. Please make sure that you have a working internet connection. " & _
            "Do you want me to prepare an error-email?", 52, "Problems connecting to Server...")
If Y = 6 Then
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Ref.Range("C7").Value2
        .CC = Ref.Range("C8").Value2
        .Subject = "Problems connecting to database '" & Ref.Range("C4").Value & "' on server '" & Ref.Range("C2").Value & "'"
        .HTMLBody = "<span style=""font-size:10px"">---Automatically generated Error-Email---" & _
                "</span><br><br>Error report from the file '" & _
                "<span style=""color:blue"">" & ActiveWorkbook.Name & _
                "</span>' located and saved on '<span style=""color:blue"">" & _
                ActiveWorkbook.Path & "</span>'.<br>" & _
                "Excel is not able to establish a connection to the server. Technical data to follow." & "<br><br>" & _
                "Computer Name:    <span style=""color:green;"">" & Environ("COMPUTERNAME") & "</span><br>" & _
                "Logged in as:     <span style=""color:green;"">" & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "</span><br>" & _
                "Domain Server:    <span style=""color:green;"">" & Environ("LOGONSERVER") & "</span><br>" & _
                "User DNS Domain:  <span style=""color:green;"">" & Environ("USERDNSDOMAIN") & "</span><br>" & _
                "Operating System: <span style=""color:green;"">" & Environ("OS") & "</span><br>" & _
                "Excel Version:    <span style=""color:green;"">" & Application.Version & "</span><br>" & _
                "<br><span style=""font-size:10px""><br>" & _
                "<br><br>---Automatically generated Error-Email---"
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End If
Exit Sub

SQL_StatementError:
Y = MsgBox("There seems to be a problem with the SQL Syntax in the programming. " & _
            "May I send an error-email to development team?", 52, "Problems with the coding...")
If Y = 6 Then
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = Ref.Range("C8").Value2
        '.CC = ""
        .Subject = "Problems with the SQL Syntax in file '" & ActiveWorkbook.Name & "'."
        .HTMLBody = "<span style=""font-size:10px"">" & _
                "---Automatically generated Error-Email---" & _
                "</span><br><br>" & _
                "Error report from the file '" & _
                "<span style=""color:blue"">" & _
                ActiveWorkbook.Name & _
                "</span>" & _
                "' located and saved on '" & _
                "<span style=""color:blue"">" & _
                ActiveWorkbook.Path & _
                "</span>" & _
                "'.<br>" & _
                "It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
                "SQL-Code causing the problems:" & _
                "<br><br><span style=""color:green;"">" & _
                strSQL & _
                "</span><br><br><span style=""font-size:10px"">" & _
                "---Automatically generated Error-Email---"
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End If
Exit Sub

End Sub