How to Import and Export Data Between Excel and SQL Server Using VBA

Function ImportSQLtoQueryTable(conString As String, query As String, target As Range) As Integer
 On Error Resume Next
 Dim ws As Worksheet
 Set ws = target.Worksheet
 Dim address As String
 address = target.Cells(1, 1).address
 ' Procedure recreates ListObject or QueryTable
 If Not target.ListObject Is Nothing Then ' Created in Excel 2007 or higher
 target.ListObject.Delete
 ElseIf Not target.QueryTable Is Nothing Then ' Created in Excel 2003
 target.QueryTable.ResultRange.Clear
 target.QueryTable.Delete
 End If
 If Application.Version >= "12.0" Then ' Excel 2007 or higher
 With ws.ListObjects.Add(SourceType:=0, Source:=Array("OLEDB;" & conString), _
 Destination:=Range(address))
 With .QueryTable
 .CommandType = xlCmdSql
 .CommandText = StringToArray(query)
 .BackgroundQuery = True
 .SavePassword = True
 .Refresh BackgroundQuery:=False
 End With
 End With
 Else ' Excel 2003
 With ws.QueryTables.Add(Connection:=Array("OLEDB;" & conString), _
 Destination:=Range(address))
 .CommandType = xlCmdSql
 .CommandText = StringToArray(query)
 .BackgroundQuery = True
 .SavePassword = True
 .Refresh BackgroundQuery:=False
 End With
 End If
 ImportSQLtoQueryTable = 0
End Function
' Source: http://support.microsoft.com/kb/816562
Function StringToArray(Str As String) As Variant
 Const StrLen = 127
 Dim NumElems As Integer
 Dim Temp() As String
 Dim i As Integer
 NumElems = (Len(Str) / StrLen) + 1
 ReDim Temp(1 To NumElems) As String
 For i = 1 To NumElems
 Temp(i) = Mid(Str, ((i - 1) * StrLen) + 1, StrLen)
 Next i
 StringToArray = Temp
End Function

Sub TestImportUsingQueryTable()
 Dim conString As String
 conString = GetTestConnectionString()
 Dim query As String
 query = GetTestQuery()
 Dim target As Range
 Set target = ThisWorkbook.Sheets(1).Cells(3, 2)
 Select Case ImportSQLtoQueryTable(conString, query, target)
 Case Else
 End Select
End Sub

Function ImportSQLtoRange(conString As String, query As String, target As Range) As Integer
 On Error Resume Next
 ' Object type and CreateObject function are used instead of ADODB.Connection,
 ' ADODB.Command for late binding without reference to
 ' Microsoft ActiveX Data Objects 2.x Library
 ' ADO API Reference
 ' https://learn.microsoft.com/en-us/previous-versions/sql/ado/reference/ado-api/ado-api-reference?view=sql-server-ver16
 ' Dim con As ADODB.Connection
 Dim con As Object
 Set con = CreateObject("ADODB.Connection")
 con.ConnectionString = conString
 ' Dim cmd As ADODB.Command
 Dim cmd As Object
 Set cmd = CreateObject("ADODB.Command")
 cmd.CommandText = query
 cmd.CommandType = 1 ' adCmdText
 ' The Open method doesn't actually establish a connection to the server
 ' until a Recordset is opened on the Connection object
 con.Open
 cmd.ActiveConnection = con
 ' Dim rst As ADODB.Recordset
 Dim rst As Object
 Set rst = cmd.Execute
 If rst Is Nothing Then
 con.Close
 Set con = Nothing
 ImportSQLtoRange = 1
 Exit Function
 End If
 Dim ws As Worksheet
 Dim col As Integer
 Set ws = target.Worksheet
 ' Column Names
 For col = 0 To rst.Fields.Count - 1
 ws.Cells(target.row, target.Column + col).Value = rst.Fields(col).Name
 Next
 ws.Range(ws.Cells(target.row, target.Column), _
 ws.Cells(target.row, target.Column + rst.Fields.Count)).Font.Bold = True
 ' Data from Recordset
 ws.Cells(target.row + 1, target.Column).CopyFromRecordset rst
 rst.Close
 con.Close
 Set rst = Nothing
 Set cmd = Nothing
 Set con = Nothing
 ImportSQLtoRange = 0
End Function

Sub TestImportUsingADO()
 Dim conString As String
 conString = GetTestConnectionString()
 Dim query As String
 query = GetTestQuery()
 Dim target As Range
 Set target = ThisWorkbook.Sheets(2).Cells(3, 2)
 target.CurrentRegion.Clear
 Select Case ImportSQLtoRange(conString, query, target)
 Case 1
 MsgBox "Import database data error", vbCritical
 Case Else
 End Select
End Sub

Sub TestImportUsingSaveToDB()
 Dim addIn As COMAddIn
 Dim addInObj As Object
 Set addIn = Application.COMAddIns("SaveToDB")
 Set addInObj = addIn.Object
 addInObj.Load
End Sub

Function ExportRangeToSQL(sourceRange As Range, conString As String, table As String, _
 Optional beforeSQL = "", Optional afterSQL As String) As Integer
 On Error Resume Next
 ' Object type and CreateObject function are used instead of ADODB.Connection,
 ' ADODB.Command for late binding without reference to
 ' Microsoft ActiveX Data Objects 2.x Library
 ' ADO API Reference
 ' https://learn.microsoft.com/en-us/previous-versions/sql/ado/reference/ado-api/ado-api-reference?view=sql-server-ver16
 ' Dim con As ADODB.Connection
 Dim con As Object
 Set con = CreateObject("ADODB.Connection")
 con.ConnectionString = conString
 con.Open
 ' Dim cmd As ADODB.Command
 Dim cmd As Object
 Set cmd = CreateObject("ADODB.Command")
 ' BeginTrans, CommitTrans, and RollbackTrans Methods (ADO)
 ' http://msdn.microsoft.com/en-us/library/ms680895(v=vs.85).aspx
 Dim level As Long
 level = con.BeginTrans
 cmd.CommandType = 1 ' adCmdText
 If beforeSQL > "" Then
 cmd.CommandText = beforeSQL
 cmd.ActiveConnection = con
 cmd.Execute
 End If
 ' Dim rst As ADODB.Recordset
 Dim rst As Object
 Set rst = CreateObject("ADODB.Recordset")
 With rst
 Set .ActiveConnection = con
 .Source = "SELECT * FROM " & table
 .CursorLocation = 3 ' adUseClient
 .LockType = 4 ' adLockBatchOptimistic
 .CursorType = 0 ' adOpenForwardOnly
 .Open
 ' Column mappings
 Dim tableFields(100) As Integer
 Dim rangeFields(100) As Integer
 Dim exportFieldsCount As Integer
 exportFieldsCount = 0
 Dim col As Integer
 Dim index As Integer
 For col = 0 To .Fields.Count - 1
 index = 0
 index = Application.Match(.Fields(col).Name, sourceRange.Rows(1), 0)
 If index > 0 Then
 exportFieldsCount = exportFieldsCount + 1
 tableFields(exportFieldsCount) = col
 rangeFields(exportFieldsCount) = index
 End If
 Next
 If exportFieldsCount = 0 Then
 ExportRangeToSQL = 1
 Goto ConnectionEnd
 End If
 ' Fast read of Excel range values to an array
 ' for further fast work with the array
 Dim arr As Variant
 arr = sourceRange.Value
 ' The range data transfer to the Recordset
 Dim row As Long
 Dim rowCount As Long
 rowCount = UBound(arr, 1)
 Dim val As Variant
 For row = 2 To rowCount
 .AddNew
 For col = 1 To exportFieldsCount
 val = arr(row, rangeFields(col))
 If IsEmpty(val) Then
 Else
 .Fields(tableFields(col)) = val
 End If
 Next
 Next
 .UpdateBatch
 End With
 rst.Close
 Set rst = Nothing
 If afterSQL > "" Then
 cmd.CommandText = afterSQL
 cmd.ActiveConnection = con
 cmd.Execute
 End If
 ExportRangeToSQL = 0
ConnectionEnd:
 con.CommitTrans
 con.Close
 Set cmd = Nothing
 Set con = Nothing
End Function

Sub TestExportUsingADO()
 Dim conString As String
 conString = GetTestConnectionString()
 Dim table As String
 table = "dbo04.ExcelTestImport"
 Dim beforeSQL As String
 Dim afterSQL As String
 beforeSQL = "EXEC dbo04.uspImportExcel_Before"
 afterSQL = "EXEC dbo04.uspImportExcel_After"
 Dim ws As Worksheet
 Set ws = ThisWorkbook.ActiveSheet
 Dim qt As QueryTable
 Set qt = GetTopQueryTable(ws)
 Dim sourceRange As Range
 If Not qt Is Nothing Then
 Set sourceRange = qt.ResultRange
 Else
 Set sourceRange = ws.Cells(3, 2).CurrentRegion
 End If
 Select Case ExportRangeToSQL(sourceRange, conString, table, beforeSQL, afterSQL)
 Case 1
 MsgBox "The source range does not contain required headers", vbCritical
 Case Else
 End Select
 ' Refresh the data
 If Not qt Is Nothing Then
 Call RefreshWorksheetQueryTables(ws)
 ElseIf ws.Name = ws.Parent.Worksheets(1).Name Then
 Else
 Call TestImportUsingADO
 End If
End Sub

Sub RefreshWorksheetQueryTables(ws As Worksheet)
 On Error Resume Next
 Dim qt As QueryTable
 For Each qt In ws.QueryTables
 qt.Refresh BackgroundQuery:=True
 Next
 Dim lo As ListObject
 For Each lo In ws.ListObjects
 lo.QueryTable.Refresh BackgroundQuery:=True
 Next
End Sub

Function GetTopQueryTable(ws As Worksheet) As QueryTable
 On Error Resume Next
 Set GetTopQueryTable = Nothing
 Dim lastRow As Long
 lastRow = 0
 Dim qt As QueryTable
 For Each qt In ws.QueryTables
 If qt.ResultRange.row > lastRow Then
 lastRow = qt.ResultRange.row
 Set GetTopQueryTable = qt
 End If
 Next
 Dim lo As ListObject
 For Each lo In ws.ListObjects
 If lo.SourceType = xlSrcQuery Then
 If lo.QueryTable.ResultRange.row > lastRow Then
 lastRow = lo.QueryTable.ResultRange.row
 Set GetTopQueryTable = lo.QueryTable
 End If
 End If
 Next
End Function

Sub TestExportUsingSaveToDB()
 Dim addIn As COMAddIn
 Dim addInObj As Object
 Set addIn = Application.COMAddIns("SaveToDB")
 Set addInObj = addIn.Object
 addInObj.Save
End Sub

Function OleDbConnectionString(Server As String, Database As String, _
 Username As String, Password As String) As String
 If Username = "" Then
 OleDbConnectionString = "Provider=SQLOLEDB.1;Data Source=" & Server _
 & ";Initial Catalog=" & Database _
 & ";Integrated Security=SSPI;Persist Security Info=False;"
 Else
 OleDbConnectionString = "Provider=SQLOLEDB.1;Data Source=" & Server _
 & ";Initial Catalog=" & Database _
 & ";User ID=" & Username & ";Password=" & Password & ";"
 End If
End Function

Function OdbcConnectionString(Server As String, Database As String, _
 Username As String, Password As String) As String
 If Username = "" Then
 OdbcConnectionString = "Driver={SQL Server};Server=" & Server _
 & ";Trusted_Connection=Yes;Database=" & Database
 Else
 OdbcConnectionString = "Driver={SQL Server};Server=" & Server _
 & ";UID=" & Username & ";PWD=" & Password & ";Database=" & Database
 End If
End Function

Contents

• Introduction
• Import using QueryTable
• Import using ADO
• Import using SaveToDB
• Export using ADO
• Export using SaveToDB
• Connection String Functions
• Conclusion
• See Also
• Download