logo标签列表

Excel VBA - 在电子表格上查询

sqlvbaexcel
6
如果我有这两个表：
如果我有这两个表：
是否有一种Excel VBA代码（使用ADO）可以实现这些所需的结果，可以利用我放在SQL表中的任何查询？
5个回答
9
这是一些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

最后，将记录集写入范围 - 如果不处理所有错误，代码将非常简单：

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

附言：在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数据提供程序仍然具有与20年前的Microsoft.Jet.OLEDB.4.0和其前身Excel ODBC驱动程序相同的内存泄漏问题。
我好像错过了 SetSchema() 函数。它在关于字节顺序标记的答案中可以找到：https://dev59.com/2kzSa4cB1Zd3GeqPkCcd#41046895 - Nigel Heffernan
1

看起来源和目标是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语句是正确的。追踪这些错误可能会让人沮丧。

我修复了你指出的错误的SQL。然后我在“工具”>“引用”中设置了“Microsoft ActiveX Data Objects 2.8 Library”，但当我运行宏时，它显示“运行时错误'424' - 需要对象。” - toop
我已经更改了所有工作表的“代号”（在VBE属性中）。每次它说wshName（比如wshResults）时，它都是指一个工作表。您需要更改您的工作表代号以匹配我的或更改代码以引用您的工作表。抱歉我之前没有提到这一点。 - Dick Kusleika
我更改了代码名称，然后运行它。出现了“运行时错误9：下标超出范围”。然后，在“替换表名”之前加入了一个msgbox sSql，msgbox显示的SQL语句为“select s.emp_no from SourceTable s inner join TargetTable t on t.employee_number = s.emp_no where s.emp_name <> t.employee_name;”（然后是下标错误）。但如果我将msgbox更改为在“替换表名”之后，我的msgbox从未出现，但下标错误确实出现了。 - toop
下标超出范围，在这个上下文中意味着你的工作表上没有任何QueryTable对象 - 它正在寻找QueryTables(1)，但找不到。这是因为你正在使用Excel 2007或更新版本，并且有ListObjects。将引用从QueryTables(1)更改为ListObjects(1).QueryTable。 - Dick Kusleika
我在使用Excel 03'，但已经添加了一个大截屏，显示了我的代码和属性。 - toop
嗨Dick - 你的回答很好，但是JET 3.5和4.0 OLEDB数据库驱动程序在直接从Excel文件中读取时存在内存泄漏问题。你可以运行查询一次，也许两次，然后一切都会变得混乱不堪...如果你幸运的话，在Excel冻结或消失之前，你会看到几个“更新显示所需的资源不足”的错误，以及粗俗的不准确言辞。 - Nigel Heffernan
1

一些注意事项：

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
1

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

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

  1. 录制宏

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

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

  4. 选择要查询的Excel表格。

  5. 每个表格都需要在一个命名范围内，保留选项选择表格，Excel目前不允许我们插入查询。

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

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

进一步的工作：所有的Excel驱动程序都有JET OLEDB 3.5和JET OLEDB 4.0驱动程序已知的内存泄漏问题。使用该驱动程序进行两三个SQL调用后，您的Excel会报告'低内存'错误 - 无法更新屏幕，由于内存原因'撤消'不再可用 - 最终您将会冻结或崩溃Excel。 - Nigel Heffernan
1

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

 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
很好的代码可用于演示SQL和ADODB连接的使用，但请注意上面有关内存泄漏的警告：当MS ACE驱动程序调用JET OLEDB库中的同一不稳定代码时，它将进入Excel。 - Nigel Heffernan
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接