ADO Function to Query most of the common Data Sources

I've lost count of the number of variants of this I've written on clients machines and have never remembered to keep a copy so wanted to write a forever one (and share with anyone that needs it of course).

Simply copy the contents of the VBA at the bottom of the article into a module in your workbook and forget about it, all you need to worry about is the ImportData Function and it's parameters and what and when to use them.

Import To Parameters

rngTarget - Range Parameter - This is the (top left) cell you wish to fill to - eg rngTarget:=Sheet1.Range("A1")

blnPivotTable - Boolean Parameter - This specifies that you want to import the data into an existing (or a automatically generated) Pivot Table - Default is False

Source Types

strFilePath - String Parameter - This is the Full File Path of your source where applicable eg. C:\Users\Michael\Documents\MyExcelFile.xlsx

lngServerType - Set By an Enum named SERVERTPYE in the below code - 1 = SQL SERVER; 2 = ORACLE; 3 = TERADATA

Server Only Parameters

strServerAddress - This is the address your server lives at

strDatabaseName - If your SQL isn't explicit you can use this to ensure the connection only looks at one of the Databases on the Server

strUserID - Your Database User ID

strPassword - Your Database Password

Data to Retrieve

strSQL - Enter your SQL Query in here

strTableToImport - If you just want the contents of a table simply enter the name here

Header Checking

varRequiredHeaders - Variant Type - Enter an array of headers here to validate your structure is as expected

blnCheckOrder - Boolean Type - If you wish to ensure the order is the same set this to True (Default is False)

For more information on how this works see here.

Usage Examples

Sub test1()

    Dim blnQuerySuccess As Boolean
     
    blnQuerySuccess = ImportData(rngTarget:=Sheet1.Range("A1"), strFilePath:="C:\Users\Michael\Documents\ABC.csv", strTableToImport:="ABC")

End Sub

Sub test2()

    Dim blnQuerySuccess As Boolean
     
    blnQuerySuccess = ImportData(rngTarget:=Sheet1.Range("A1"), blnPivotTable:=True, strFilePath:="C:\Users\Michael\Documents\Branch DW.accdb", strSQL:="SELECT * FROM [tbl_Finance_CoOp]")

End Sub

Sub Test3()

    Dim blnQuerySuccess As Boolean
    Dim varHeaders As Variant
    
    varHeaders = Array("Field1", "Field2", "Field3")
     
    blnQuerySuccess = ImportData(rngTarget:=Sheet1.Range("A1"), lngServerType:=SQLSERVER, strUserID:="MyAccount", strPassword:="MyPassword", strTableToImport:="tbl_Finance_CoOp", varRequiredHeaders:=varHeaders, blnCheckOrder:=True)

End Sub

Things to remember

1) The majority of these parameters are optional so please keep in mind that you only need to use those relevant to the source you are querying and for example don't set both options of the same thing strSQL & strTableToImport - Only one of these needs setting.

2) I've not tested the Server options but they *should* work perfectly, if you run into problems let me know and I'll happily amend the code.

3) When querying .txt's and .csv's the connection is made to the folder not the file - please do point strFilePath to a File and not a folder, it will step back from the file and retrieve the folder so you can still query multiple text files in one SQL string.

4) When querying Excel Files remember to add a $ to the end of any table names in your custom SQL. If using the strTableToImport parameter the $ is added for you.

5) Yes I know many people will tell me simply to use Power Query, I can see the comments already, if you do then expect backlash as not everybody has access to the Power Tools as not all companies use the most up to date versions of Excel.

Hope somebody finds this useful and if there are any bugs (that don't stem from your shoddy SQL) please let me know in the comments or by LinkedIn Messenger and I'll look to rectify them.

Option Explicit

Public Const strACCESS_SOURCE = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=#DATABASE_PATH#;Persist Security Info=False;"
Public Const strCSV_SOURCE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=#DATABASE_PATH#;Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
Public Const strXLS_SOURCE = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=#DATABASE_PATH#;Extended Properties=""Excel 8.0;HDR=YES"";"
Public Const strXLSX_SOURCE = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=#DATABASE_PATH#;Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Public Const strXLSM_SOURCE = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=#DATABASE_PATH#;Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
Public Const strXLSB_SOURCE = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=#DATABASE_PATH#;Extended Properties=""Excel 12.0;HDR=YES"";"
Public Const strSQLSERVER_SOURCE = "Provider=SQLOLEDB;Server=#SERVER#;Database=#DATABASE#;Trusted_Connection=Yes;"
Public Const strORACLE_SOURCE = "Data Source=#SERVER#;User Id=#USERNAME#;Password=#PASSWORD#;Integrated Security=no;"
Public Const strTERADATA_SOURCE = "Provider=TDOLEDB;Data Source=#SERVER#;Persist Security Info=True;User ID=#USERNAME#;Password=#PASSWORD#;Session Mode=ANSI;"
Public Const strTEXT_SOURCE = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=#DATABASE_PATH#;Extended Properties=""text;HDR=Yes;FMT=Delimited"";"

Public blnIsExcelFile As Boolean

Public Enum SERVERTYPE
    SQLSERVER = 1
    ORACLE = 2
    TERADATA = 3
End Enum

Function ImportData(ByRef rngTarget As Range, _
                    Optional ByRef strFilePath As String, _
                    Optional ByRef lngServerType As SERVERTYPE, _
                    Optional ByRef strServerAddress As String, _
                    Optional ByRef strDatabaseName As String, _
                    Optional ByRef strUserID As String, _
                    Optional ByRef strPassword As String, _
                    Optional ByRef strSQL As String, _
                    Optional ByRef strTableToImport As String, _
                    Optional ByRef varRequiredHeaders As Variant, _
                    Optional ByRef blnCheckOrder = False, _
                    Optional ByRef blnPivotTable As Boolean = False) As Boolean

    Dim blnFailedValidation As Boolean
    Dim con As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim lngHeader As Long, lngDecision As Long, lngFields As Long
    Dim pvc As PivotCache
    Dim strConnectionString As String, strPivotName As String, strExtension As String
    Dim varHeaders As Variant, varMatches As Variant, varPivotName As Variant
    
    ImportData = False
    On Error GoTo Finish
    
    strExtension = GetExtension(strFilePath)
    
    If strExtension = "txt" Or strExtension = "csv" Then
        strConnectionString = Replace(GetConnectionString(strFilePath, lngServerType), "#DATABASE_PATH#", Left$(strFilePath, InStrRev(strFilePath, Application.PathSeparator)))
    Else
        strConnectionString = Replace(Replace(Replace(Replace(Replace(GetConnectionString(strFilePath, lngServerType), "#DATABASE_PATH#", strFilePath), "#SERVER#", strServerAddress), "#DATABASE#", strDatabaseName), "#USERNAME#", strUserID), "#PASSWORD#", strPassword)
    End If
    If Len(strSQL) = 0 Then strSQL = "SELECT * FROM [" & strTableToImport & IIf(blnIsExcelFile, "$", "") & "];"
    
    con.Open strConnectionString
    With rst
        .Open Source:=strSQL, ActiveConnection:=con
        If TypeName(varRequiredHeaders) = "String" Then
            If Len(varRequiredHeaders) > 0 Then
                varHeaders(0) = varRequiredHeaders
            Else
                GoTo SkipValidation
            End If
        ElseIf TypeName(varRequiredHeaders) = "Error" Then
            GoTo SkipValidation
        Else
            For lngHeader = UBound(varRequiredHeaders) To LBound(varRequiredHeaders)
                varHeaders(lngHeader) = .Fields(lngHeader).Name
            Next lngHeader
        End If
    End With
    
    varMatches = Application.Match(varRequiredHeaders, varHeaders, 0)
    blnFailedValidation = Application.CountA(varRequiredHeaders) <> _
                          Application.Count(varMatches)
                      
    If blnCheckOrder And Not blnFailedValidation Then
        For lngHeader = LBound(varMatches) To UBound(varMatches)
            If varMatches(lngHeader) <> lngHeader Then
                blnFailedValidation = True
                lngDecision = MsgBox(Prompt:="Headers do not match required headers, do you wish to proceed anyway?", Buttons:=vbExclamation + vbYesNo, Title:="Failed Validation")
                If lngDecision = 7 Then GoTo Finish
            End If
        Next lngHeader
    End If
    
SkipValidation:

    With rngTarget
        On Error Resume Next
        varPivotName = .PivotTable.Name
        If varPivotName <> "" Or blnPivotTable Then
            Err.Clear
            On Error Resume Next
            Set .PivotTable.PivotCache.Recordset = rst
            .PivotTable.RefreshTable
            If Err.Number > 0 Then
                .PivotTable.TableRange2.Delete
                Set pvc = ThisWorkbook.PivotCaches.Create(xlExternal)
                Set pvc.Recordset = rst
                pvc.CreatePivotTable .Cells(1, 1), varPivotName
            End If
            ImportData = True
            GoTo Finish
        End If
        .Resize(1, 1).Offset(1).CopyFromRecordset rst
        For lngFields = 0 To rst.Fields.Count - 1
            rngTarget.Resize(1, 1).Offset(0, lngFields).Value = rst.Fields(lngFields).Name
        Next lngFields
    End With
    ImportData = True
    
Finish:
    
    On Error Resume Next
    rst.Close
    con.Close
    
    Set rst = Nothing
    Set con = Nothing

End Function

Function GetConnectionString(ByRef strFilePath As String, ByRef lngServerType As Long) As String

    Dim strExtension As String
    
    If Len(strFilePath) > 0 Then
        Select Case GetExtension(strFilePath)
            Case "accdb", "mdb"
                GetConnectionString = strACCESS_SOURCE
                blnIsExcelFile = False
            Case "txt", "csv"
                GetConnectionString = strCSV_SOURCE
                blnIsExcelFile = False
            Case "xls"
                GetConnectionString = strXLS_SOURCE
                blnIsExcelFile = True
            Case "xlsx"
                GetConnectionString = strXLSX_SOURCE
                blnIsExcelFile = True
            Case "xlsm"
                GetConnectionString = strXLSM_SOURCE
                blnIsExcelFile = True
            Case "xlsb"
                GetConnectionString = strXLSB_SOURCE
                blnIsExcelFile = True
        End Select
    Else
        Select Case lngServerType
            Case 1
                GetConnectionString = strSQLSERVER_SOURCE
                blnIsExcelFile = False
            Case 2
                GetConnectionString = strORACLE_SOURCE
                blnIsExcelFile = False
            Case 3
                GetConnectionString = strTERADATA_SOURCE
                blnIsExcelFile = False
        End Select
    End If
                
End Function

Function GetExtension(ByRef strFilePath As String) As String

    Dim strExtension As String
    Dim varFileTypes As Variant, varMatch As Variant
    
    strExtension = Right$(strFilePath, Len(strFilePath) - InStrRev(strFilePath, "."))
    varFileTypes = Array("accdb", "mdb", "txt", "csv", "xls", "xlsx", "xlsm", "xlsb")

    varMatch = Application.Match(strExtension, varFileTypes, 0)
    
    If IsNumeric(varMatch) Then
        GetExtension = strExtension
    Else
        GetExtension = ""
    End If

End Function