excel vba - query on a spreadsheet_问答_开发者

if i have these 2 tables:

excel vba - query on a spreadsheet

is there some sort of excel 开发者_JS百科vba code (using ADO) that could acheive these desired results which could utilise any query i put in the SQL sheet?

excel vba - query on a spreadsheet

Here's some VBA code that allows you to read an Excel range using the text SQL driver. It's quite a complex example, but I'm guessing that you came here because you're a fairly advanced user with a more complex problem than the examples we see on other sites.

Before I post the code in full, here's the original 'sample usage' comment in the core function, FetchXLRecordSet:

' Sample usage:
'
'   Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap")
'
' Where the query uses two named ranges, "TableAccountLookup" and "TableCashMap"
' as shown in this SQL statement:
'
'  SELECT
'      B.Legal_Entity_Name, B.Status,
'      SUM(A.USD_Settled) As Settled_Cash
'  FROM
'      [TableAccountLookup] AS A,
'      [TableCashMap] AS B
'  WHERE
'      A.Account  IS NOT NULL
'  AND B.Cash_Account  IS NOT NULL
'  AND A.Account = B.Cash_Account
'  GROUP BY
'      B.Legal_Entity_Name,
'      B.Status

It's clunky, forcing you to name the tables (or list the range addresses in full) when you run the query, but it simplifies the code.

Option Explicit
Option Private Module

' ADODB data retrieval functions to support Excel
' Online reference for connection strings:
' http://www.connectionstrings.com/oracle#p15
' Online reference for ADO objects & properties:
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
' External dependencies:
' Scripting - C:\Program files\scrrun.dll
' ADO       - C:\Program files\Common\system\ado\msado27.tlb

Private m_strTempFolder As String
Private m_strConXL      As String
Private m_objConnXL     As ADODB.Connection


Public Property Get XLConnection() As ADODB.Connection
On Error GoTo ErrSub

' The Excel database drivers have memory problems so we use the text driver
' to read csv files in a temporary folder. We populate these files from
' ranges specified for use as tables by the FetchXLRecordSet() function.

Dim objFSO As Scripting.FileSystemObject    
Set objFSO = New Scripting.FileSystemObject
Set m_objConnXL = New ADODB.Connection

    ' Specify and clear a temporary folder:    
    m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath    
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If    
    m_strTempFolder = m_strTempFolder & "XLSQL"    
    Application.DisplayAlerts = False
    If objFSO.FolderExists(m_strTempFolder) Then
        objFSO.DeleteFolder m_strTempFolder
    End If
    If Not objFSO.FolderExists(m_strTempFolder) Then
        objFSO.CreateFolder m_strTempFolder
    End If        
    If Right(m_strTempFolder, 1) <> "\" Then
        m_strTempFolder = m_strTempFolder & "\"
    End If 
 
' JET OLEDB text driver connection string:
'   Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited";
' ODBC text driver connection string:
'   Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
    m_strConXL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";"
    m_strConXL = m_strConXL & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1" & Chr(34) & ";" 

    With m_objConnXL
        .CursorLocation = adUseClient
        .CommandTimeout = 90
        .ConnectionString = m_strConXL
        .Mode = adModeRead
    End With

If m_objConnXL.State = adStateClosed Then
    Application.StatusBar = "Connecting to the local Excel tables"
    m_objConnXL.Open
End If

Set XLConnection = m_objConnXL

ExitSub:
    Application.StatusBar = False
    Exit Property    

ErrSub:
    MsgPopup "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10
    Resume ErrEnd
    ' Resume ExitSub

ErrEnd:
    End   ' Terminal error. Halt.

End Property


Public Sub CloseConnections()

On Error Resume Next
Set m_objConnXL = Nothing

End Sub


Public Function FetchXLRecordSet(ByVal SQL As String, ParamArray TableNames()) As ADODB.Recordset

' This allows you to retrieve data from Excel ranges using SQL. You
' need to pass additional parameters specifying each range you're using as a table
' so that the these ranges can be saved as csv files in the 'XLSQL' temporary folder
' Note that your query must use the 'table' naming conventions required by the Excel
' database drivers: http://www.connectionstrings.com/excel#20

On Error Resume Next

Dim i As Integer
Dim iFrom As Integer
Dim strRange As String
Dim j As Integer
Dim k As Integer

If IsEmpty(TableNames) Then
    TableNames = Array("")
End If

If InStr(TypeName(TableNames), "(") < 1 Then
    TableNames = Array(TableNames)
End If

Set FetchXLRecordSet = New ADODB.Recordset

With FetchXLRecordSet    
    .CacheSize = 8
    Set .ActiveConnection = XLConnection    
    iFrom = InStr(8, SQL, "From", vbTextCompare) + 4  
  
    For i = LBound(TableNames) To UBound(TableNames)    
        strRange = ""
        strRange = TableNames(i)        
        If strRange = "0" Or strRange = "" Then
            j = InStr(SQL, "FROM") + 4
            j = InStr(j, SQL, "[")
            k = InStr(j, SQL, "]")
            strRange = Mid(SQL, j + 1, k - j - 1)
        End If        
        RangeToFile strRange
        SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1)
        SQL = Replace(SQL, "$.csv", ".csv")
        SQL = Replace(SQL, ".csv$", ".csv")
        SQL = Replace(SQL, ".csv.csv", ".csv")        
    Next i 
  
    .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
    i = 0
    Do While .State > 1
        i = (i + 1) Mod 3
        Application.StatusBar = "Connecting to the database" & String(i, ".")
        Sleep 250
    Loop    

End With

Application.StatusBar = False

End Function


Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String
' Read a range into a string.
' Each row is delimited with a carriage-return and a line break.
' Empty cells are concatenated into the string as 'Tabs' of four spaces.
'NH Feb 2018: you cannot return more than 32767 chars into a range.

Dim i As Integer
Dim j As Integer
Dim arrCells   As Variant
Dim arrRows()  As String
Dim arrRowX()  As String
Dim strRow     As String
Dim boolIndent As Boolean

Const SPACE   As String * 1 = " "
Const SPACE4  As String * 4 = "    "
Const MAX_LEN As Long = 32767

arrCells = SQL_Range.Value2

If InStr(TypeName(arrCells), "(") Then

  ReDim arrRows(LBound(arrCells, 1) To UBound(arrCells, 1))
  ReDim arrRowX(LBound(arrCells, 2) To UBound(arrCells, 2))  

  For i = LBound(arrCells, 1) To UBound(arrCells, 1) - 1
    boolIndent = True

    For j = LBound(arrCells, 2) To UBound(arrCells, 2)
      If isError(arrCells(i, j)) Then
        SQL_Range(i, j).Calculate
      End If      
      If Not isError(arrCells(i, j)) Then
        arrRowX(j) = arrCells(i, j)
      Else
        arrRowX(j) = vbNullString
      End If      
      If boolIndent And arrRowX(j) = "" Then
        arrRowX(j) = SPACE4
      Else
        boolIndent = False
      End If      
    Next j 
       
    arrRows(i) = Join(arrRowX, SPACE)    

    If Len(Trim$(arrRows(i))) = 0 Then
      arrRows(i) = vbNullString
    Else
      arrRows(i) = RTrim$(Join(arrRowX, SPACE))
    End If   
 
  Next i  

  Erase arrCells
  Erase arrRowX  
  ReadRangeSQL = Join(arrRows, vbCrLf)  
  Erase arrRows  
  ReadRangeSQL = Replace(ReadRangeSQL, vbCrLf & vbCrLf, vbCrLf)

Else
  ReadRangeSQL = CStr(arrCells)
End If

If Len(ReadRangeSQL) > MAX_LEN Then
  ' Trip terminating spaces from each row:
  Do While InStr(1, ReadRangeSQL, SPACE & vbCrLf, vbBinaryCompare) > 0
    ReadRangeSQL = Replace(ReadRangeSQL, SPACE & vbCrLf, vbCrLf)
  Loop  
End If

If Len(ReadRangeSQL) > MAX_LEN Then
   ' Reduce the 'tab' size to 2 selectively, after each row's indentation
  arrRows = Split(ReadRangeSQL, vbCrLf)
  For i = LBound(arrRows) To UBound(arrRows)
    If Len(arrRows(i)) > 16 Then
      If InStr(12, arrRows(i), SPACE4) > 0 Then
        arrRows(i) = Left$(arrRows(i), 12) & Replace(Right$(arrRows(i), Len(arrRows(i)) - 12), SPACE4, SPACE & SPACE)
      End If
    End If
  Next i

  ReadRangeSQL = Join(arrRows, vbCrLf)
  Erase arrRows   
End If

If Len(ReadRangeSQL) > MAX_LEN Then
  ' Reduce the 'tab' size to 2 indiscriminately. This will make your SQL illegible:
  Do While InStr(1, ReadRangeSQL, SPACE4, vbBinaryCompare) > 0
    ReadRangeSQL = Replace(ReadRangeSQL, SPACE4, SPACE & SPACE)
  Loop
End If

End Function 


Public Sub RangeToFile(ByRef strRange As String)
' Output a range to a csv file in a temporary folder created by the XLConnection function
' strRange specifies a range in the current workbook using the 'table' naming conventions
' specified for Excel OLEDB database drivers:   http://www.connectionstrings.com/excel#20
' The first row of the range is assumed to be a set of column names.

On Error Resume Next

Dim objFSO As Scripting.FileSystemObject
Dim rng     As Excel.Range
Dim strFile As String
Dim arrData As Variant
Dim iRow    As Long
Dim jCol    As Long
Dim strData As String
Dim strLine As String

strRange = Replace(strRange, "[", "")
strRange = Replace(strRange, "]", "")

If Right(strRange, 1) = "$" Then
    strRange = Replace(strRange, "$", "")
    Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
Else
    strRange = Replace(strRange, "$", "")
    Set rng = Range(strRange)    
    If rng Is Nothing Then
        Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
    End If
End If

If rng Is Nothing Then
    Exit Sub
End If

Set objFSO = New Scripting.FileSystemObject
strFile = m_strTempFolder & strRange & ".csv"

If objFSO.FileExists(strFile) Then
    objFSO.DeleteFile strFile, True
End If

If objFSO.FileExists(strFile) Then
    Exit Sub
End If

arrData = rng.Value2

With objFSO.OpenTextFile(strFile, ForWriting, True)

    ' Header row:
    strLine = ""
    strData = ""

    iRow = LBound(arrData, 1)

    For jCol = LBound(arrData, 2) To UBound(arrData, 2)
        strData = arrData(iRow, jCol)
        strData = Replace(strData, Chr(34), Chr(39))
        strData = Replace(strData, Chr(10), " ")
        strData = Replace(strData, Chr(13), " ")
        strData = strData & ","
        strLine = strLine & strData
    Next jCol   
 
    strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma        
    If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
        .WriteLine strLine
    End If
        
    ' Rest of the data
    For iRow = LBound(arrData, 1) + 1 To UBound(arrData, 1) 
   
        strLine = ""
        strData = ""    
    
        For jCol = LBound(arrData, 2) To UBound(arrData, 2)
            If IsError(arrData(iRow, jCol)) Then
                strData = "#ERROR"
            Else
                strData = arrData(iRow, jCol)
                strData = Replace(strData, Chr(34), Chr(39))
                strData = Replace(strData, Chr(10), " ")
                strData = Replace(strData, Chr(13), " ")
                strData = Replace(strData, Chr(9), " ")
                strData = Trim(strData)
            End If

            strData = Chr(34) & strData & Chr(34) & ","  ' Quotes to coerce all values to text
            strLine = strLine & strData
        Next jCol  
      
        strLine = Left(strLine, Len(strLine) - 1)    ' Trim trailing comma
        If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
            .WriteLine strLine
        End If

    Next iRow   
 
.Close
End With ' textstream object from objFSO.OpenTextFile

Set objFSO = Nothing
Erase arrData
Set rng = Nothing

End Sub

And finally, Writing a Recordset to a Range - the code would be trivial if it wasn't for all the errors you have to handle:

Public Sub RecordsetToRange(rngTarget As Excel.Range, objRecordset As ADODB.Recordset, Optional FieldList As Variant, Optional ShowFieldNames As Boolean = False, Optional Orientation As Excel.XlRowCol = xlRows)

' Write an ADO Recordset to an Excel range in a single 'hit' to the sheet
' Calling function is responsible for setting the record pointer (must not be EOF!)
' The target range is resized automatically to the dimensions of the array, with the top left cell used as the start point.

On Error Resume Next

Dim OutputArray As Variant
Dim i           As Integer
Dim iCol        As Integer
Dim iRow        As Integer
Dim varField    As Variant

If objRecordset Is Nothing Then
  Exit Sub
End If

If objRecordset.State <> 1 Then
  Exit Sub
End If

If objRecordset.BOF And objRecordset.EOF Then
    Exit Sub
End If

If Orientation = xlColumns Then
    If IsEmpty(FieldList) Or IsMissing(FieldList) Then
        OutputArray = objRecordset.GetRows
    Else
        OutputArray = objRecordset.GetRows(Fields:=FieldList)
    End If
Else
    If IsEmpty(FieldList) Or IsMissing(FieldList) Then
        OutputArray = ArrayTranspose(objRecordset.GetRows)
    Else
        OutputArray = ArrayTranspose(objRecordset.GetRows(Fields:=FieldList))
    End If
End If

ArrayToRange rngTarget, OutputArray

If ShowFieldNames Then

  If Orientation = xlColumns Then

    ReDim OutputArray(LBound(OutputArray, 1) To UBound(OutputArray, 1), 1 To 1)
    iRow = LBound(OutputArray, 1)

    If IsEmpty(FieldList) Or IsMissing(FieldList) Then

      For i = 0 To objRecordset.Fields.Count - 1
        If i > UBound(OutputArray, 1) Then
          Exit For
        End If
        OutputArray(iRow + i, 1) = objRecordset.Fields(i).Name
      Next i

    Else

      If InStr(TypeName(FieldList), "(") < 1 Then
        FieldList = Array(FieldList)
      End If
      i = 0
      For Each varField In FieldList
        OutputArray(iRow + i, 1) = CStr(varField)
        i = i = 1

      Next

    End If  'IsEmpty(FieldList) Or IsMissing(FieldList)

    ArrayToRange rngTarget.Cells(1, 0), OutputArray

  Else

    ReDim OutputArray(1 To 1, LBound(OutputArray, 2) To UBound(OutputArray, 2))
    iCol = LBound(OutputArray, 2)

    If IsEmpty(FieldList) Or IsMissing(FieldList) Then

      For i = 0 To objRecordset.Fields.Count - 1
        If i > UBound(OutputArray, 2) Then
          Exit For
        End If
        OutputArray(1, iCol + i) = objRecordset.Fields(i).Name
      Next i

    Else

      If InStr(TypeName(FieldList), "(") < 1 Then
        FieldList = Array(FieldList)
      End If
      i = 0
      For Each varField In FieldList
        OutputArray(1, iCol + i) = CStr(varField)
        i = i = 1
      Next

    End If  ' IsEmpty(FieldList) Or IsMissing(FieldList)

    ArrayToRange rngTarget.Cells(0, 1), OutputArray

  End If ' Orientation = xlColumns

End If 'ShowFieldNames

Erase OutputArray

End Sub


Public Function ArrayTranspose(InputArray As Variant) As Variant
' Transpose InputArray.
' Returns InputArray unchanged if it is not a 2-Dimensional Variant(x,y)

Dim iRow As Long
Dim iCol As Long
Dim iRowCount As Long
Dim iColCount As Long
Dim boolNoRows As Boolean
Dim BoolNoCols As Boolean
Dim OutputArray As Variant

If IsEmpty(InputArray) Then
    ArrayTranspose = InputArray
    Exit Function
End If

If InStr(1, TypeName(InputArray), "(") < 1 Then
    ArrayTranspose = InputArray
    Exit Function
End If

' Check that we can read the array's dimensions:
On Error Resume Next

    Err.Clear
    iRowCount = 0
    iRowCount = UBound(InputArray, 1)

    If Err.Number <> 0 Then
        boolNoRows = True
    End If

    Err.Clear
    Err.Clear
    iColCount = 0
    iColCount = UBound(InputArray, 2)

    If Err.Number <> 0 Then
        BoolNoCols = True
    End If

    Err.Clear

If boolNoRows Then

    ' ALL arrays have a defined Ubound(MyArray, 1)!
    ' This variant's dimensions cannot be determined
     OutputArray = InputArray

ElseIf BoolNoCols Then

    ' It's a vector. Strictly speaking, a vector cannot be 'transposed', as
    ' calling the ordinal a 'row' or a 'column' is arbitrary or meaningless.
    ' But... By convention, Excel users regard a vector as an array of 1 to n
    ' rows and 1 column. So we'll 'transpose' it into a Variant(1 to 1, 1 to n)
    ReDim OutputArray(1 To 1, LBound(InputArray, 1) To UBound(InputArray, 1))

    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        OutputArray(1, iRow) = InputArray(iRow)
    Next iRow

Else

    ReDim OutputArray(LBound(InputArray, 2) To UBound(InputArray, 2), LBound(InputArray, 1) To UBound(InputArray, 1))

    If IsEmpty(OutputArray) Then
        ArrayTranspose = InputArray
        Exit Function
    End If

    If InStr(1, TypeName(OutputArray), "(") < 1 Then
        ArrayTranspose = InputArray
        Exit Function
    End If

    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
            OutputArray(iCol, iRow) = InputArray(iRow, iCol)
        Next iCol
    Next iRow

End If

ExitFunction:
    ArrayTranspose = OutputArray
    Erase OutputArray
End Function

Postscript: Running SQL on Excel 'Table' Objects

For completeness, here's the code for a barebones 'read Excel Table objects with SQL' function that handles all the text-file hacking in the background.

I'm posting it now, a while after my original answer went up, because everyone's using the rich 'table' object for tabulated data in Excel:


' Run a JOIN query on your tables, and write the field names and data to Sheet1:
SaveTable "Table1"
SaveTable "Table2"
SQL= SQL & "SELECT * "
SQL= SQL & " FROM Table1 "
SQL= SQL & " LEFT JOIN Table2 "
SQL= SQL & "   ON Table1.Client = Table2.Client"
RunSQL SQL, Sheet1.Range("A1")

...And the full listing (give or take a couple of functions in the previous code dump) is:

Public Function RunSQL(SQL As String, TargetRange As Excel.Range, Optional DataSetName As String) 

' Run SQL against table files in the local ExcelSQL folder and write the results to a target range
' The full implementation of ExcelSQL provides a fully-featured UI on a control sheet
' This is a cut-down version which runs everything automatically, without audit & error-reporting
' SQL can be read from ranges using the ReadRangeSQL function
' If no target range object is passed in, and a Data set name is specified, the recordset will be
' saved as [DataSetName].csv in the local Excel SQL folder for subsequent SQL queries
' If no target range is specified and no Data set name specified, returns the recordet object

Dim rst As ADODB.Recordset

If Left(SQL, 4) = "SQL_" Then
    SQL = ReadRangeSQL(ThisWorkbook.Names(SQL).RefersToRange)
End If

Set rst = FetchTextRecordset(SQL)

If TargetRange Is Nothing Then
    If DataSetName = "" Then
        Set RunSQL = rst
    Else
        RecordsetToCSV rst, DataSetName, , , , , , , False
        Set rst = Nothing
    End If    
Else
    RecordsetToRange rst, TargetRange, True
    Set rst = Nothing
End If

End Function


Public Function FetchTextRecordset(SQL As String) As ADODB.Recordset
' Fetch records from the saved text files in the Temp SQL Folder:
On Error Resume Next

Dim i As Integer
Dim iFrom As Integer

If InStr(1, connText, "IMEX=1", vbTextCompare) > 0 Then SetSchema
Set FetchTextRecordset = New ADODB.Recordset

With FetchTextRecordset

    .CacheSize = 8
    Set .ActiveConnection = connText
    On Error GoTo ERR_ADO
    .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
    i = 0

    Do While .State > 1
        i = (i + 1) Mod 3
        Application.StatusBar = "Waiting for data" & String(i, ".")
        Application.Wait Now + (0.25 / 24 / 3600)
    Loop   
 
End With

Application.StatusBar = False

ExitSub:
    Exit Function 
   
ERR_ADO:
Dim strMsg    
    strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the developer, or " & SUPPORT & "."

    If Verbose Then
        MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext
    End If
    Resume ExitSub 
   
Exit Function

    ' Try this if SQL is too big to debug in the immediate window:
    '  FSO.OpenTextFile("C:\Temp\SQL.txt",ForWriting,True).Write SQL
    '  Shell "Notepad.exe C:\Temp\SQL.txt", vbNormalFocus
'Resume
End Function


Private Property Get connText() As ADODB.Connection
On Error GoTo ErrSub

Dim strTempFolder

If m_objConnText Is Nothing Then    

    Set m_objConnText = New ADODB.Connection
    strTempFolder = TempSQLFolder   ' this will test whether the folder permits SQL READ operations    
    Application.DisplayAlerts = False       
' MS-Access ACE OLEDB Provider
   m_strConnText = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & strTempFolder & Chr(34) & ";Persist Security Info=True;"
   m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;CharacterSet=UNICODE;HDR=Yes;HDR=Yes;IMEX=1;MaxScanRows=1" & Chr(34) & ";"    

End If

If Not m_objConnText Is Nothing Then    

    With m_objConnText    
        If .State = adStateClosed Then        
            Application.StatusBar = "Connecting to the local Excel tables"
            .CursorLocation = adUseClient
            .CommandTimeout = 90
            .ConnectionString = m_strConnText
            .Mode = adModeRead
            .Open                        
        End If        
    End With

    If m_objConnText.State = adStateClosed Then
        Set m_objConnText = Nothing
    End If 
    
End If

Set connText = m_objConnText

ExitSub:
    Application.StatusBar = False
    Exit Property    
ErrSub:
    MsgBox "Error connecting to the Excel local data. Please contact " & SUPPORT & ".", vbCritical + vbApplicationModal, "Database connection failure!", 10
    Resume ErrEnd
    ' Resume ExitSub
ErrEnd:
    End   ' Terminal error. Halt.

End Property


Public Sub CloseConnections()
On Error Resume Next

Set m_objConnText = Nothing

End Sub

Public Function TempSQLFolder() As String
Application.Volatile False

' Location of temporary table files used by the SQL text data functions
' Also runs a background process to clear out files over 7 days old
' The best location is a named subfolder in the user's temp folder. The
' user local 'temp' folder is discoverable on all Windows systems using
' GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath
' and will usually be  C:\Users\[User Name]\AppData\Local\Temp
' Dependencies:
'   Object Property FSO (Returns Scripting.FilesystemObject)
'
Dim strCMD              As String
Dim strMsg              As String
Dim strNamedFolder      As String
Static strTempFolder    As String  ' Cache it
Dim iRetry              As Integer
Dim i As Long

' If we've already found a usable temp folder, use the static value
' without querying the file system and testing write privileges again:

If strTempFolder <> "" Then
    TempSQLFolder = strTempFolder
    Exit Function
End If

On Error Resume Next

    strTempFolder = GetObject("Scripting.FileSystemObject").GetSpecialFolder(2).ShortPath   

    If Right(strTempFolder, 1) <> "\" Then
        strTempFolder = strTempFolder & "\"
    End If    

    strTempFolder = strTempFolder & "XLSQL"    

    If Not FSO.FolderExists(strTempFolder) Then
        FSO.CreateFolder strTempFolder
    End If      
 
    i = 1
    Do Until FSO.FolderExists(strTempFolder) Or i > 6
        Sleep i * 250
        Application.StatusBar = "Waiting for SQL cache folder" & String(i Mod 4, ".")
    Loop

    If Not FSO.FolderExists(strTempFolder) Then
        GoTo Retry
    End If   
 
    If Right(strTempFolder, 1) <> "\" Then
        strTempFolder = strTempFolder & "\"
    End If 
 
TempSQLFolder = strTempFolder    
Application.StatusBar = False    

End Function


Public Property Get FSO() As Scripting.FileSystemObject           '
' Return a File System Object
On Error Resume Next

If m_objFSO Is Nothing Then
    Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If

If m_objFSO Is Nothing Then
    Shell "Regsvr32.exe /s scrrun.dll", vbHide
    Set m_objFSO = CreateObject("Scripting.FileSystemObject")
End If

Set FSO = m_objFSO

End Property


Public Sub SaveTable(Optional TableName As String = "*")
' Export a Table object to the local SQL Folder as a csv file
' If no name is specified, all tables are exported asynchronously
' This step is essential for running SQL on the tables

Dim wks     As Excel.Worksheet
Dim oList   As Excel.ListObject
Dim sFile   As String
Dim bAsync  As Boolean

If TableName = "*" Then
    bAsync = True
Else
    bAsync = False
End If

For Each wks In ThisWorkbook.Worksheets
    For Each oList In wks.ListObjects
        If oList.Name Like TableName Then
            sFile = oList.Name
            ArrayToCSV oList.Range.Value2, sFile, , , , , , , , bAsync
            'Debug.Print "[" & sFile & ".csv] "
        End If
    Next oList
Next wks

SetSchema

End Sub

Public Sub RemoveTable(Optional TableName As String = "*")
On Error Resume Next

' Clear up the temporary 'Table' files in the user local temp folder:

Dim wks     As Excel.Worksheet
Dim oList   As Excel.ListObject
Dim sFile   As String
Dim sFolder  As String

sFolder = TempSQLFolder

For Each wks In ThisWorkbook.Worksheets

    For Each oList In wks.ListObjects    
        If oList.Name Like TableName Then
            sFile = oList.Name & ".csv"
            If Len(Dir(sFile)) > 0 Then
                Shell "CMD /c DEL " & Chr(34) & sFolder & sFile & Chr(34), vbHide      ' asynchronous deletion
            End If
        End If        
    Next oList

Next wks

End Sub

Share and enjoy: this is all a horrible hack, but it gives you a stable SQL platform.

And we still don't have a stable 'native' platform for SQL on Excel: the Microsoft.ACE.OLEDB.14.0 Excel data provider still has the same memory leak as Microsoft.Jet.OLEDB.4.0 and the Excel ODBC driver that preceded it, twenty years ago.

Some notes:

sFullName = ActiveWorkbook.FullName
sSheet = ActiveSheet.Name

Set cn = CreateObject("adodb.connection")
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& sFullName _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

cn.Open scn

Set rs = CreateObject("adodb.recordset")

For Each c In Sheet4.UsedRange
    sSQL = sSQL & c.Value & " "
Next

rs.Open sSQL, cn

Sheet5.Range("a10").CopyFromRecordset rs

There is an ODBC driver for Excel.
See: http://support.microsoft.com/kb/178717
And: http://msdn.microsoft.com/en-us/library/ms711711%28v=vs.85%29.aspx

In order to get data out of a database and into Excel you do the following steps.

Record a macro
Import external data, choose a new source, select DSN ODBC as the type of source.
Now choose Excel-file as the type of ODBC source.
Pick the Excel sheet you want to query.
Every table needs to be in a named range, leave the option select a table checked, Excel will not allow us to insert a query just yet.
Follow the wizard and save the .odc file. Open it again and choose edit query. Now you can insert your select statement.
Stop recording and edit the recorded macro to suit your needs.

It looks like source and target are odbc queries. You need to parse the table name out of those queries and replace SoureTable and TargetTable in your query with the right table names.

Sub ExecuteSQL()

    Dim sSql As String
    Dim rCell As Range
    Dim adConn As ADODB.Connection
    Dim adRs As ADODB.Recordset

    Dim lWherePos As Long

    Const sSOURCE As String = "SourceTable"
    Const sTARGET As String = "TargetTable"
    Const sODBC As String = "ODBC;"

    'Buld the sql statement
    For Each rCell In Intersect(wshSql.UsedRange, wshSql.Columns(1)).Cells
        If Not IsEmpty(rCell.Value) Then
            sSql = sSql & rCell.Value & Space(1)
        End If
    Next rCell

    'replace the table names
    sSql = Replace(sSql, sSOURCE, GetTableName(wshSource.QueryTables(1).CommandText), 1, 1)
    sSql = Replace(sSql, sTARGET, GetTableName(wshTarget.QueryTables(1).CommandText), 1, 1)

    'execute the query
    Set adConn = New ADODB.Connection
    adConn.Open Replace(wshSource.QueryTables(1).Connection, sODBC, "")
    Set adRs = adConn.Execute(sSql)

    'copy the results
    wshResults.Range("A1").CopyFromRecordset adRs

    adRs.Close
    adConn.Close
    Set adRs = Nothing
    Set adConn = Nothing

End Sub

Function GetTableName(sSql As String) As String

    Dim lFromStart As Long
    Dim lFromEnd As Long
    Dim sReturn As String

    Const sFROM As String = "FROM "
    Const sWHERE As String = "WHERE "

    'find where FROM starts and ends
    'I'm looking for WHERE as the end, but you'll need to look for everything possible, like ORDER BY etc.
    lFromStart = InStr(1, sSql, sFROM)
    lFromEnd = InStr(lFromStart, sSql, sWHERE)

    If lFromEnd = 0 Then
        sReturn = Mid$(sSql, lFromStart + Len(sFROM), Len(sSql))
    Else
        sReturn = Mid$(sSql, lFromStart + Len(sFROM), lFromEnd - lFromStart - Len(sFROM) - 1)
    End If

    GetTableName = sReturn

End Function

Another problem that you might run into is the way Excel (or MSQuery) constructs the SQL statements in an external data query. If you leave it as the default, you'll likely get something like this

SELECT * FROM `C:\somepath\myfile.mdb`.tblTable1 tblTable1 WHERE ...

I have no idea why it does it that way, but you can change it to

SELECT * FROM tblTable1 WHERE ...

and the above code should work. Parsing SQL statements sucks, so don't expect this to be easy. Once you think you have all the possibilities, another will pop up.

Finally, you should get the error "Too few parameters, expected 1" or something similar. In SourceTable, the first field is emp_no, but you have emp_id in your SQL. Make sure your SQL in the SQL sheet is correct. It can be frustrating trying to track down those errors.

I'm using very simple code which helps me to query worksheet range :

 Sub hello_jet()

    Dim rs As ADODB.Recordset
    Dim cn As ADODB.Connection
    Dim strQuery As String

    Set cn = New ADODB.Connection

    With cn
      .Provider = "Microsoft.ACE.OLEDB.12.0" 
      .ConnectionString = "Data Source=C:\yourPath\ADO_test.xls " & _
      ";Extended Properties=""Excel 8.0;HDR=Yes;"""
    .Open
    End With
    'Microsoft.ACE.OLEDB.12.0 for database engine built in Windows 7 64


    strQuery = "SELECT a,sum(c) FROM [Sheet1$A1:C6] GROUP BY a;"
    ''if range [Sheet1$A1:C6] is named as namedRange you can you its name directly in query:
    'strQuery = "SELECT a,sum(c) FROM namedRange GROUP BY a;"

    Set rs = cn.Execute(strQuery)

    ActiveCell.CopyFromRecordset rs 'useful method

    rs.Close

    End Sub