使用ADO将Excel电子表格导入数组的更快捷方式

时间：2014-11-04 19:24:59

标签： excel vba excel-vba excel-2007 ado

我正在尝试使用Excel 2007 VBA将大型Excel报表中的数据导入并排序到新文件中。到目前为止，我已经提出了两种方法：

  1. 让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

  2. 使用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

    3. 使用的测试文件有大约65000条记录需要排序（约占我最终使用它的三分之一）。当ADO版本仅比开放式工作表略好（约44秒vs~40秒运行时间）时，我有点失望。我想知道是否有某种方法来改进ADO导入方法（或者一种完全不同的方法 - ExecuteExcel4Macro可能？ - 如果有的话）可以提高我的速度。我唯一能想到的是我使用"B1:Z180000"作为我的SourceRange作为最大范围，然后通过设置Arr = rs.GetRows来截断，以准确反映记录总数。如果这是导致速度减慢的原因，我不确定如何查找工作表中有多少行。

    编辑 - 我正在使用Range（＆＃34; A1：A＆＃34;＆amp; i）=（数组）将数据插入新工作表。

2 个答案:

答案 0 :(得分：0)

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

在这里，我正在处理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行的形式传输。 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

答案 1 :(得分：0)

我认为@Mr。 Mascaro是将Recordset数据传输到电子表格的最简单方法：

Private Sub PopArray()
    .....
    Set rs = dbConnection.Execute("SELECT * FROM [" & SourceRange & "]")  
    '' This is faster
    Range("A1").CopyFromRecordset rs
    ''Arr = rs.GetRows
End Sub

但如果您仍想使用Arrays，可以试试这个：

Sub ArrayTest  

'' Array for Test
Dim aSingleArray As Variant  
Dim aMultiArray as Variant  

'' Set values 
aSingleArray = Array("A","B","C","D","E")  
aMultiArray = Array(aSingleArray, aSingleArray)

'' You can drop data from the Array using 'Resize'
'' Btw, your Array must be transpose to use this :P
Range("A1").Resize( _
            UBound(aMultiArray(0), 1) + 1, _  
            UBound(aMultiArray, 1) + 1) = Application.Transpose(aMultiArray)

End Sub
相关问题
最新问题