SQL excel vba - 在电子表格上查询

excel vba - query on a spreadsheet

提问by toop

if i have these 2 tables:

如果我有这两张表：

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

是否有某种 excel vba 代码（使用 ADO）可以实现这些所需的结果，这些结果可以利用我放在 SQL 表中的任何查询？

回答by Nigel Heffernan

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.

下面是一些 VBA 代码，它允许您使用文本 SQL 驱动程序读取 Excel 范围。这是一个相当复杂的例子，但我猜你来到这里是因为你是一个相当高级的用户，比我们在其他网站上看到的例子更复杂。

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

在我完整发布代码之前，这里是核心函数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:

最后，将 Recordset 写入范围 - 如果不是您必须处理的所有错误，代码将是微不足道的：

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

    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

    ArrayToRange rngTarget.Cells(0, 1), OutputArray

  End If

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

Let me know how you get on. As always, watch out for formatting glitches: I've never got the <code> tags to work on this site, and <PRE> isn't always respected by textboxes when the preformatted text contains quotes and HTML entities.

让我知道你是怎么办的。与往常一样，注意格式错误：我从来没有让 <code> 标签在这个网站上工作，并且当预格式化的文本包含引号和 HTML 实体时，文本框并不总是尊重 <PRE>。

Postscript: Running SQL on Excel 'Table' Objects

后记：在 Excel“表”对象上运行 SQL

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.

为了完整起见，这里是一个准系统“使用 SQL 读取 Excel 表对象”函数的代码，该函数在后台处理所有文本文件黑客攻击。

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:

我现在发布它，在我最初的答案出现一段时间后，因为每个人都在 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")

...完整清单（在之前的代码转储中给出或接受几个函数）是：

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.

分享和享受：这都是一个可怕的黑客，但它为您提供了一个稳定的 SQL 平台。

And we stilldon'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.

而且我们仍然没有用于 Excel 上的 SQL 的稳定“本机”平台：Microsoft.ACE.OLEDB.14.0 Excel 数据提供程序仍然存在与 Microsoft.Jet.OLEDB.4.0 和之前的 Excel ODBC 驱动程序相同的内存泄漏它，二十年前。

回答by Fionnuala

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

回答by Johan

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

有一个用于 Excel 的 ODBC 驱动程序。
请参阅：http: //support.microsoft.com/kb/178717
和：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.

为了从数据库中获取数据并导入 Excel，您需要执行以下步骤。

1. Record a macro

2. Import external data, choose a new source, select DSN ODBC as the type of source.

3. Now choose Excel-file as the type of ODBC source.

4. Pick the Excel sheet you want to query.

5. Every tableneeds to be in a named range, leave the option select a tablechecked, Excel will not allow us to insert a query just yet.

6. Follow the wizard and save the .odc file. Open it again and choose edit query. Now you can insert your select statement.

7. Stop recording and edit the recorded macro to suit your needs.

1. 录制宏

2. 导入外部数据，选择新来源，选择 DSN ODBC 作为来源类型。

3. 现在选择 Excel 文件作为 ODBC 源的类型。

4. 选择要查询的 Excel 工作表。

5. 每个都table需要在命名范围内，select a table选中该选项，Excel 还不允许我们插入查询。

6. 按照向导操作并保存 .odc 文件。再次打开它并选择编辑查询。现在您可以插入您的选择语句。

7. 停止录制并编辑录制的宏以满足您的需要。

回答by Dick Kusleika

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.

看起来源和目标是 odbc 查询。您需要从这些查询中解析表名，并用正确的表名替换查询中的 SoureTable 和 TargetTable。

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

您可能遇到的另一个问题是 Excel（或 MSQuery）在外部数据查询中构造 SQL 语句的方式。如果您将其保留为默认值，您可能会得到这样的结果

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.

上面的代码应该可以工作。解析 SQL 语句很糟糕，所以不要指望这很容易。一旦你认为你有所有的可能性，另一个就会出现。

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.

最后，您应该收到错误“参数太少，预期为 1”或类似的错误。在 SourceTable 中，第一个字段是 emp_no，但您的 SQL 中有 emp_id。确保 SQL 表中的 SQL 正确。试图追踪这些错误可能会令人沮丧。

回答by Qbik

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