(Solved) – Identifying areas to improve VBA code when writing to SQL

  • by
(solved)-–-identifying-areas-to-improve-vba-code-when-writing-to-sql

I am looking for ways to optimize the below module.

I’ll have a role in which I’m frequently required to update databases with large datasets that I receive in an excel sheet/workbook. I’ve made a module to import the sheet into a specified database. Using the stringbuilder class here –

https://codereview.stackexchange.com/questions/196076/bringing-the-system-text-stringbuilder-up-to-lightning-speed-in-the-vba

It works for very large datasets and handles all exceptions I’ve come across (as long as no strings are in numeric columns) as far as I’ve tested but I’m more worried about performance. Write now it writes at about 650 rows/sec into sql server. Are there any more opportunities to dump memory in this/increase speed? There has to be something because the larger the dataset the lower the rate of importing. I’m not sure if that’s the server however.

Main function, loops through the row then iterates to the next one, building the formatted insert sql statement.

Public Sub buildQuery()
        Dim sb As StringBuilder
        Set sb = New StringBuilder
        Dim queryText As String
        Application.ScreenUpdating = False
        lr = Cells(Rows.Count, 4).End(xlUp).row
        lc = Cells(1, Columns.Count).End(xlToLeft).column
        Dim MyTimer As Date
        MyTimer = Now
        Debug.Print MyTimer

    For i = 2 To lr

    Application.StatusBar = "Progress: " & i & " of " & lr & " : " & format(i / lr, "0%")

        If (i Mod 1000) = 0 Then
            sb.Append buildRow(currentCell, i, n, lc)
            queryText = intoStatement()   sb.ToString
            queryText = Left(queryText, Len(queryText) - 1)
            query (queryText)
            Set sb = Nothing
            queryText = Nothing
            Set sb = New StringBuilder
            i = i   1
            End If

        sb.Append buildRow(currentCell, i, n, lc)
        sb.Append vbNewLine

    Next i

    queryText = intoStatement()   sb.ToString
    queryText = Left(queryText, Len(queryText) - 3)
    query (queryText)

MyTimer = Now
Debug.Print MyTimer
Application.ScreenUpdating = True
Application.StatusBar = False
End
End Sub

There were some extremely low values imported in the sheet causing type errors server side I had to handle so I made this. It simply rounds negative numbers to the 10th decimal place.

Function smallNo(no As Variant)

If IsNumeric(no) Then
     If no < 0 Then
     smallNo = Round(no, 10)
     Else
     smallNo = no
     End If

End Function

This builds and returns a single row formatted as SQL requires

Function buildRow(currentCell As Variant, i As Variant, n As Variant, lc As Variant) As String

Dim sb As StringBuilder
Set sb = New StringBuilder

      For n = 1 To lc
        currentCell = smallNo(Cells(i, n))

        Select Case True
            Case IsError(currentCell), IsEmpty(currentCell)
                If n = 1 Then
                sb.Append ("(NULL,")
                ElseIf n = lc Then
                sb.Append "NULL),"
                Else
                sb.Append "NULL,"
                End If
            Case Else
               cellString = Replace(CStr(currentCell), ("'"), "")
                If n = 1 Then
                    sb.Append "('" & cellString & "',"
                ElseIf n = lc Then
                    sb.Append "'" & cellString & "'), "
                Else
                sb.Append Chr(39) & cellString & "',"
                End If
        End Select
        Next n
        buildRow = sb.ToString
        Set sb = Nothing
End Function

Building the insert *** values from the headers. Assumes headers are the same as column names in the database table. Ideally the header column in the spreadsheet would be the only edit you have to make before importing.

Public Function intoStatement() As String
With ActiveSheet
 lc = .Cells(1, .Columns.Count).End(xlToLeft).column
    Dim headerCells As Variant
    headerCells = .Range(.Cells(1, 1), .Cells(1, lc))
End With

Dim headers As String
headers = Join(Application.Transpose(Application.Transpose(headerCells)), ",")

intoStatement = "INSERT INTO " & _
"[tempdb].[dbo].testDB3 (" & headers & ") Values "

End Function

Where we open the connection to sql server and execute the built query. The stringbuilder object queryText are dumped after this executes

Function query(sqlStr As String)

Dim connection As New ADODB.connection
Dim strSQL As New ADODB.Command
Dim connString As String

connection.Open "DRIVER={SQL Server};SERVER=DESKTOP;" & _
       "trusted_connection=yes;dsn=tw;DATABASE=tempdb"

strSQL.ActiveConnection = connection
strSQL.CommandText = sqlStr
strSQL.CommandType = adCmdText

strSQL.Execute

connection.Close


End Function

Leave a Reply

Your email address will not be published. Required fields are marked *