Question

如果我有这两个表：

source

target

sql

result

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

Answer 1

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

在我完整发布代码之前，这是核心函数中的原始“示例用法”注释， 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

它很笨重，迫使你在运行查询时命名表（或列出完整的范围地址），但它简化了代码。

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

最后，将一个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

让我知道你是怎么过的。一如既往，注意格式化故障：我从来没有得到＆lt; code＆gt;标记在此网站上工作，＆lt; PRE＆gt;当预格式化的文本包含引号和HTML实体时，文本框并不总是受到尊重。

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

为了完整性，这里是一个准系统的代码，用于读取具有SQL'功能的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

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

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

Answer 2

一些注意事项：

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

Answer 3

Excel有一个ODBC驱动程序见：http://support.microsoft.com/kb/178717
并且：http://msdn.microsoft.com/en-us/library/ms711711%28v=vs.85%29.aspx

要从数据库和Excel中获取数据，请执行以下步骤。

录制宏
导入外部数据，选择新来源，选择DSN ODBC作为来源类型。
现在选择Excel文件作为ODBC源的类型。
选择您要查询的Excel工作表。
每个table都需要在命名范围内，选中select a table选项，Excel将不允许我们插入查询。
按照向导并保存.odc文件。再次打开它并选择编辑查询。现在您可以插入您的select语句。
停止录制并编辑录制的宏以满足您的需要。

Answer 4

看起来源和目标是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

您可能遇到的另一个问题是Excel（或MSQuery）在外部数据查询中构造SQL语句的方式。如果你把它作为默认值，你可能会得到类似的东西

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

我不知道为什么会这样做，但您可以将其更改为

SELECT * FROM tblTable1 WHERE ...

以上代码应该有效。解析SQL语句很糟糕，所以不要指望这很简单。一旦你认为你拥有所有可能性，就会弹出另一个可能性。

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

Answer 5

我使用非常简单的代码来帮助我查询工作表范围：

 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

excel vba - 在电子表格上查询

5 个答案:

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