Sub QueryTableMacro()

Dim wks As Worksheet
Dim qt As QueryTable

Dim i As Integer

Dim strAccessFilePath As String
Dim strSQL As String
Dim strDestinationRange As String
Dim strDir As String
Dim strConnection As String


    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Set up master information - could be passed as arguments
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ' Access file path
    strAccessFilePath = "C:\My database.mdb"

    ' SQL query
    strSQL = "SELECT `Information`.`Building Name`, "
    strSQL = strSQL & "`Information`.`Street Address`, "
    strSQL = strSQL & "`Information`.Town, "
    strSQL = strSQL & "`Information`.County, "
    strSQL = strSQL & "`Information`.Postcode"
    strSQL = strSQL & Chr(13) & "" & Chr(10)
    strSQL = strSQL & "FROM `Information` `Information`"

    ' Destination range
    strDestinationRange = "A1"

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Add a new sheet
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Set wks = ThisWorkbook.Sheets.Add
    wks.Name = Format(Now, "dmmmyy hhmm")

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Determine the Connection variable
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ' Find the Path
    i = 1
    strDir = strAccessFilePath
    Do Until InStr(i, strDir, "\", vbBinaryCompare) = 0
        i = InStr(i, strDir, "\", vbBinaryCompare) + 1
    Loop
    strDir = Left(strDir, i - 1)

    ' Set the Connection string
    strConnection = "ODBC;" & _
                    "DSN=MS Access Database;" & _
                    "DBQ=" & strAccessFilePath & ";" & _
                    "DefaultDir=" & strDir & ";" & _
                    "FIL=MS Access;" & _
                    "MaxBufferSize=2048;" & _
                    "PageTimeout=5;"

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Add the QueryTable
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Set qt = wks.QueryTables.Add( _
        Connection:=strConnection, _
        Destination:=wks.Range(strDestinationRange), _
        Sql:=strSQL)

    ' Set the remaining query table properties
    ' NB you must run the Refresh method if you want any data
    With qt
        .Name = "Query from MS Access Database"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With

End Sub