Import SQL Server data into Microsoft Excel using VBA

SQL Server Data Import to Excel using ADO;Import SQL Server data into Microsoft Excel using VBA;Excel-SQL Server Import-Export using VBA: ADO and QueryTabl

SQL Server Data Import to Excel using ADO

1) The function inserts SQL Server data to the target Excel range using ADO.

Function ImportSQLtoExcel(sheet As String, row As Long, column As Long, commandText As String) As Integer
     ' requires a reference to the object library "Microsoft ActiveX Data Objects 2.x Library" under Options > Tools > References... in the Visual Basic Editor.

    Dim rangesheet As String
    rangesheet = Sheets(sheet).Cells(row + 1, column).Address
    
    Dim database As String
    Dim UID As String
    Dim PWD As String
    
    database = Sheets("Configuration").Cells(2, Range("Configuration[[#All],[CONFIGURATION_DATABASE]]").column).Value
    UID = Sheets("Configuration").Cells(2, Range("Configuration[[#All],[UID]]").column).Value
    PWD = Sheets("Configuration").Cells(2, Range("Configuration[[#All],[PWD]]").column).Value
    
       
    Dim connectionsheet As String
    
    connectionsheet = OdbcConnectionStringSQLServer("SQL Server", Server, database, UID, PWD)
    
    Dim cnt As ADODB.Connection
    Set cnt = New ADODB.Connection
    cnt.ConnectionString = connectionsheet
    cnt.Open
    
    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = cnt
    cmd.commandText = commandText
    cmd.CommandType = adCmdText
       
    ' Object type and CreateObject function are used instead of ADODB.RECORDSET,
    ' After late binding without reference to
    ' Microsoft ActiveX Data Objects 2.x Library
    Dim rs As Object
    Set rs = CreateObject("ADODB.RECORDSET")
    rs.ActiveConnection = cnt
    rs.Open commandText, cnt
  
'Deletes ListObjet or QueryTable if already exist

    If Sheets(sheet).ListObjects.Count > 0 Then 'created in Excel 2007 or higher
       
        For Each tbl In Sheets(sheet).ListObjects
            tbl.Delete
        Next tbl
    ElseIf Sheets(sheet).QueryTables.Count > 0 Then ' Created in Excel 2003
         For Each tbl In Sheets(sheet).QueryTables
            tbl.ResultRange.Clear
            tbl.Delete
        Next tbl
    End If
  

   With Sheets(sheet).ListObjects.Add(SourceType:=3, Source:=rs, Destination:=Range(Sheets(sheet).Cells(row, column).Address)).QueryTable
       
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCell
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .RefreshPeriod = 0
        .ListObject.Name = displayname
        .ListObject.ShowTotals = False
        .Refresh BackgroundQuery:=False
    End With
    
   Sheets(sheet).ListObjects(displayname).TableStyle = "TableStyleMedium9"
   ImportSQLtoExcel = 0
   
CloseRecordset:
    rs.Close
    Set rs = Nothing
CloseConnection:
    cnt.Close
    Set cnt = Nothing
       
End Function

Function OdbcConnectionStringSQLServer(ByVal Driver As String, ByVal Server As String, ByVal database As String, _
    ByVal Username As String, ByVal Password As String) As String

'SQL Server
  
     OdbcConnectionStringSQLServer = "Driver={" & Driver & "};Server=" & Server _
            & ";UID=" & Username & ";PWD=" & Password & ";Database=" & database
  

End Function