Faster Way to Import Excel Spreadsheet to Array With ADO

Question

I am trying to import and sort data from a large excel report into a new file using Excel 2007 VBA. I have come up with two methods so far for doing this:

Answer 1

This answer might not be what you are looking for but I still felt compelled to post it based on your side note [...] or a completely different method ]...].

Here, I am working with files of 200MB (and more) each which are merely text files including delimiters. I do not load them into Excel anymore. I also had the problem that Excel was too slow and needs to load the entire file. Yet, Excel is very fast at opening these files using the Open method:

Open strFileNameAndPath For Input Access Read Lock Read As #intPointer

In this case Excel is not loading the entire file but merely reading it line by line. So, Excel can already process the data (forward it) and then grab the next line of data. Like this Excel does not neet the memory to load 200MB.

With this method I am then loading the data in a locally installed SQL which transfers the data directly to our DWH (also SQL). To speed up the transfer using the above mething and getting the data fast into the SQL server I am transferring the data in chunks of 1000 rows each. The string variable in Excel can hold up to 2 billion characters. So, there is not problem there.

One might wonder why I am not simply using SSIS if I am already using a local installation of SQL. Yet, the problem is that I am not the one loading all these files anymore. Using Excel to generate this "import tool" allowed me to forward these tools to others, who are now uploading all these files for me. Giving all of them access to SSIS was not an option nor the possibility of using a destined network drive where one could place these files and SSIS would automatically load them (ever 10+ minutes or so).

In the end my code looks something like this.

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 = "---Automatically generated Error-Email---" & _
                "

Error report from the file '" & _
                "" & ActiveWorkbook.Name & _
                "' located and saved on '" & _
                ActiveWorkbook.Path & "'.
" & _
                "Excel is not able to establish a connection to the server. Technical data to follow." & "

" & _
                "Computer Name:    " & Environ("COMPUTERNAME") & "
" & _
                "Logged in as:     " & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "
" & _
                "Domain Server:    " & Environ("LOGONSERVER") & "
" & _
                "User DNS Domain:  " & Environ("USERDNSDOMAIN") & "
" & _
                "Operating System: " & Environ("OS") & "
" & _
                "Excel Version:    " & Application.Version & "
" & _
                "

" & _
                "

---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 = "" & _
                "---Automatically generated Error-Email---" & _
                "

" & _
                "Error report from the file '" & _
                "" & _
                ActiveWorkbook.Name & _
                "" & _
                "' located and saved on '" & _
                "" & _
                ActiveWorkbook.Path & _
                "" & _
                "'.
" & _
                "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:" & _
                "

" & _
                strSQL & _
                "

" & _
                "---Automatically generated Error-Email---"
        .Display
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End If
Exit Sub

End Sub