用ADO快速将Excel电子表格导入数组

4xy9mtcn  于 2022-12-05  发布在  其他
关注(0)|答案(2)|浏览(161)

我正在尝试使用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

1.使用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秒vs ~40秒运行时间）。我想知道是否有一些方法可以改进ADO导入方法（或者一个完全不同的方法-也许是ExecuteExcel 4 Macro？-如果有的话），这会提高我的速度。我能想到的唯一一件事是，我使用"B1:Z180000"作为最大范围，然后通过设置Arr = rs.GetRows来截断，以准确反映记录的总数。如果这就是导致速度变慢的原因，我不确定如何才能找到工作表中有多少行。
编辑-我正在使用Range（“A1：A”& i）=（Array）将数据插入新工作表。

excel

2条答案

按热度按时间
bf1o4zei

bf1o4zei1#

这个答案可能不是你想要的，但我仍然觉得有必要根据你的侧记[...]或完全不同的方法[...]发布它。
在这里，我正在处理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
赞(0）分享  回复(0）举报  2022-12-05
tez616oj

tez616oj2#

我认为@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
赞(0）分享  回复(0）举报  2022-12-05
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备2022004421号-2 NULL123 https://www.null123.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com