excel vba - 在电子表格上查询 [英] excel vba - query on a spreadsheet

查看：226 发布时间：2017/9/7 1:46:32 sql excel vba excel-vba

本文介绍了excel vba - 在电子表格上查询的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

如果我有这两个表：

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

解决方案

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

在我发布完整的代码之前，这里是核心函数中的原始示例使用注释， FetchXLRecordSet ：

 
'示例用法：
'
'设置rst = FetchXLRecordSet（SQL，TableAccountLookup，TableCashMap）
'
'查询使用的位置两个命名范围，TableAccountLookup和TableCashMap
'，如此SQL语句所示：
'
'SELECT 
'B.Legal_Entity_Name，B.Status，
'SUM（A.USD_Setled）As Settled_Cash 
'FROM 
'[TableAccountLookup] AS A，
'[TableCashMap] AS B 
'WHERE 
'A.帐户IS NOT NULL 
'AND B.Cash_Account IS NOT NULL 
'AND A.Account = B.Cash_Account 
'Group BY 
'B.Legal_Entity_Name，
'B.Status< BR />

这有点笨拙，强迫你命名表（或列出范围地址全部）当你运行查询，但是这样做简化了代码。

选项显式
选项私人模块

'ADODB数据检索功能支持Excel

'连接字符串的在线参考：
' a href =http://www.connectionstrings.com/oracle#p15 =nofollow noreferrer> http://www.connectionstrings.com/oracle#p15

'ADO对象的在线参考属性：
' http：// msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx

'外部依赖关系：

'脚本 - C：\Program files\scrrun.dll
'ADO - C：\Program files\Common\system\ado\msado27。 tlb

私人m_strTempFolder As String
私有m_strConXL As String
私有m_objConnXL作为ADODB.Connection

公共属性获取XLConnection（）作为ADODB.Connection
错误GoTo ErrSub

'Excel数据库驱动程序在Excel应用程序的多个实例时有问题
'正在运行，所以我们使用文本驱动程序来读取临时文件夹中的csv文件。这些文件
'由FetchXLRecordSet（）函数指定用作表格的范围填充。

Dim objFSO As Scripting.FileSystemObject

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

 '指定并清除临时文件夹：
 
 m_strTempFolder = objFSO.GetSpecialFolder（Scripting.TemporaryFolder）.ShortPath 
 
如果右（m_strTempFolder，1）< \然后
 m_strTempFolder = m_strTempFolder& \
 End If 
 
 m_strTempFolder = m_strTempFolder& XLSQL
 
 Application.DisplayAlerts = False 
 
如果objFSO.FolderExists（m_strTempFolder）然后
 objFSO.DeleteFolder m_strTempFolder 
 End If 
如果不是objFSO.FolderExists（m_strTempFolder）然后
 objFSO.CreateFolder m_strTempFolder 
 End If 
 
如果右（m_strTempFolder，1）< \然后
 m_strTempFolder = m_strTempFolder& \
如果

'JET OLEDB文本驱动程序连接字符串：
'Provider = Microsoft.Jet.OLEDB.4.0;数据源= c：\txtFilesFolder\;扩展属性=文本; HDR =是; FMT =分隔;

'ODBC文本驱动程序连接字符串：
'Driver = {Microsoft Text Driver（* .txt; * .csv）}; Dbq = c：\txtFilesFolder\; Extensions = asc，csv， txt;

  m_strConXL =Provider = Microsoft.Jet.OLEDB.4.0; Data Source =& m_strTempFolder& ; 
 m_strConXL = m_strConXL& 扩展属性=& Chr（34）& text; HDR = Yes; IMEX = 1& Chr（34）& ; 
 
与m_objConnXL $ b $ b .CursorLocation = adUseClient 
 .CommandTimeout = 90 
 .ConnectionString = m_strConXL $ b $ b .Mode = adModeRead 
结束

如果m_objConnXL.State = adStateClosed然后
Application.StatusBar =连接到本地Excel表
m_objConnXL.Open
结束如果

设置XLConnection = m_objConnXL

ExitSub：
Application.StatusBar = False
退出属性

ErrSub：
MsgPopup连接到Excel本地数据时出错，请联系应用程序支持。，vbCritical + vbApplicationModal，数据库连接失败！，10
恢复ErrEnd
'恢复ExitSub
ErrEnd：
结束'终端错误。停。
结束属性

公共Sub CloseConnections（）

错误恢复下一步

Set m_objConnXL = Nothing

End Sub

公共函数FetchXLRecordSet ByVal SQL As String，ParamArray TableNames（））作为ADODB.Recordset
'这允许您使用SQL从Excel范围检索数据。你
'需要传递额外的参数，指定您使用的每个范围作为表
'，以便这些范围可以保存为XLSQL临时文件夹中的csv文件

'请注意，您的查询必须使用Excel
'数据库驱动程序所需的表命名约定： 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（）
如果

如果InStr（TypeName（TableNames），（）< 1 Then
TableNames = Array（TableNames）
End If

设置FetchXLRecordSet =新的ADODB.Recordset

使用FetchXLRecordSet

  .CacheSize = 8 
设置.ActiveConnectio n = XLConnection 
 
 iFrom = InStr（8，SQL，From，vbTextCompare）+ 4 
 
对于i = LBound（TableNames）到UBound（TableNames）
 
 strRange =
 strRange = TableNames（i）
 
如果strRange =0或strRange =然后
j = InStr（SQL，FROM ）+ 4 
j = InStr（j，SQL，[）
k = InStr（j，SQL，]）
 strRange = Mid（SQL，j + 1， j  -  1）
 End If 
 
 RangeToFile strRange 
 SQL = Left（SQL，iFrom）&替换（SQL，strRange，strRange&.csv，iFrom + 1，1）
 SQL =替换（SQL，$ .csv，.csv）
 SQL = ，.csv $，.csv）
 SQL =替换（SQL，.csv.csv，.csv）
 
下一个i 
 
。打开SQL，adOpenStatic，adCmdText + adAsyncFetch 
 
i = 0 
尽管.State> 1 
 i =（i + 1）Mod 3 
 Application.StatusBar =连接数据库& String（i，。）
睡眠250 
循环

结束于

Application.StatusBar = False

结束功能

公共函数ReadRangeSQL（SQL_Range As Excel.Range）As String
'将范围读入字符串。
'每行都用回车符和换行符分隔。
'空单元格连接到四个空格的Tabs字符串。

Dim i As Integer
Dim j As Integer
Dim arrRows As Variant
Dim strRow As String

arrRows = SQL_Range.Value2

如果InStr （TypeName（arrRows），（）Then

  For i = LBound（arrRows，1）To UBound（arrRows，1 ）
 
 strRow =
 
对于j = LBound（arrRows，2）到UBound（arrRows，2）
 
如果Trim（arrRows i，j））=然后
 arrRows（i，j）=
 End If 
 strRow = strRow& arrRows（i，j）
 
下一步j 
 
 strRow = RTrim（strRow）
如果strRow<>然后
 ReadRangeSQL = ReadRangeSQL& strRow& vbCrLf 
 End If 
 
下一个i 
 
删除arrRows

其他
ReadRangeSQL = CStr（arrRows）
如果

结束功能

公共子范围ToFile（ByRef strRange As String）
'将一个范围输出到由XLConnection函数创建的临时文件夹中的csv文件
'strRange使用'table'命名约定指定当前工作簿中的范围
'为Excel OLEDB数据库驱动程序指定： http://www.connectionstrings.com/excel#20

'请注意，范围的第一行被假定为一组列名。

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 =替换（strRange，[，）
strRange =替换（strRange，]，）

如果右（strRange，1）=$然后
strRange = Replace（strRange， $，）
设置rng = ThisWorkbook.Worksheets（strRange）.UsedRange
Else
strRange =替换（strRange，$，）
设置rng =范围（strRange）

 如果rng不是，然后
设置rng = ThisWorkbook.Worksheets（strRange）.UsedRange 
结束如果

结束如果

如果rng不是，然后
退出Sub
结束如果

设置objFSO = New Scripting.FileSystemObject
strFile = m_strTempFolder& strRange& .csv

如果objFSO.FileExists（strFile）然后
objFSO.DeleteFile strFile，True
End If

如果objFSO.FileExists（strFile）然后
Exit Sub
End If

arrData = rng.Value2

使用objFSO.OpenTextFile（strFile，ForWriting，True）

 '标题行：
 strLine =
 strData =
 iRow = LBound（arrData，1）
对于jCol = LBound（arrData，2）到UBound（arrData，2） 
 strData = arrData（iRow，jCol）
 strData =替换（strData，Chr（34），Chr（39））
 strData = Replace（strData，Chr（10），） 
 strData = Replace（strData，Chr（13），）
 strData = strData& ，
 strLine = strLine& strData 
下一个jCol 
 
 strLine = Left（strLine，Len（strLine） -  1）'修剪尾随逗号
 
如果Len（替换（替换（strLine，Chr （34），），，，））> 0然后
 .WriteLine strLine 
结束如果
 
'剩余的数据
对于iRow = LBound（arrData，1）+ 1 To UBound（arrData，1） 
 
 strLine =
 strData =
 
对于jCol = LBound（arrData，2）到UBound（arrData，2）
如果IsError （arrData（iRow，jCol））然后
 strData =#ERROR
 Else 
 strData = arrData（iRow，jCol）
 strData =替换（strData，Chr（34） ，Chr（39））
 strData =替换（strData，Chr（10），）'删除换行符不符合RFC 4180标准
 strData =替换（strData，Chr（13） ）'...但是如果我们没有
 Excel Excel驱动程序将中断strData = Replace（strData，Chr（9），）
 strData = Trim（strData）
 End If 
 strData = Chr（34）& strData& Chr（34）& ，'用引号封闭所有值到文本
 strLine = strLine& strData 
下一个jCol 
 
 strLine = Left（strLine，Len（strLine） -  1）'修剪尾随逗号
 
如果Len（替换（替换（strLine，Chr （34），），，，））> 0然后
 .WriteLine strLine 
结束如果
 
下一步iRow

。关闭
结束与objFSO.OpenTextFile的文本流对象

设置objFSO = Nothing
擦除arrData
设置rng =没有

End Sub

最后，写一个记录集到一个范围 - 代码将是微不足道的，如果不是所有的错误，你必须处理，这是你将要做的很多事情：

Public Sub RecordsetToRange（rngTarget As Excel.Range，objRecordset As ADODB.Recordset，Optional FieldList As Variant，Optional ShowFieldNames As Boolean = False，可选方向为Excel.XlRowCol = xlRows）
'将ADO记录集写入Excel范围单个打到工作表
'调用函数负责设置记录指针（不能为EOF！）

'目标范围自动调整为数组的维度h左上角的单元格作为起始点。

On Error Resume Next

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

如果objRecordset不是然后
Exit Sub
End If

如果objRecordset.State<> 1然后
退出Sub
End If

如果objRecordset.BOF和objRecordset.EOF然后
退出子
结束如果

如果Orientation = xlColumns Then
If IsEmpty（FieldList）或IsMissing（FieldList）Then
OutputArray = objRecordset.GetRows
Else
OutputArray = objRecordset.GetRows（Fields：= FieldList）
End If
Else
如果IsEmpty（FieldList）或IsMissing（FieldList）然后
OutputArray = ArrayTranspose（objRecordset.GetRows）
Else
OutputArray = ArrayTranspose objRecordset.GetRows（Fields：= FieldList））
如果
结束If

ArrayToRange rngTarget，OutputArray

如果ShowFieldNames Then

 如果Orientation = xlColumns然后
 
 ReDim OutputArray（LBound（OutputArray，1）To UBound（OutputArray，1），1到1）
 
 iRow = LBound（OutputArray，1）
 
如果IsEmpty（FieldList）或IsMissing（FieldList）然后
对于i = 0 To objRecordset.Fields .Count  -  1 
如果我> UBound（OutputArray，1）然后
退出
结束If 
 OutputArray（iRow + i，1）= objRecordset.Fields（i）.Name 
 Next i 
 Else 
如果InStr（TypeName（FieldList），（）< 1 Then 
 FieldList = Array（FieldList）
 End If 
i = 0 
 For Each varField在FieldList 
 OutputArray（iRow + i，1）= CStr（varField）
i = i = 1 
下一个
结束如果
 
 ArrayToRange rngTarget.Cells （1，0），OutputArray 
 
 Else 
 
 ReDim OutputArray（1到1，LBound（OutputArray，2）到UBound（OutputArray，2））
 
 
 iCol = LBound（OutputArray，2）
 
如果IsEmpty（FieldList）或IsMissing（FieldList）然后
对于i = 0 To objRecordset.Fields.Count  -  1 
如果我> UBound（OutputArray，2）然后
退出
结束If 
 OutputArray（1，iCol + i）= objReco rdset.Fields（i）.Name 
 Next i 
 Else 
如果InStr（TypeName（FieldList），（）< 1然后
 FieldList = Array（FieldList）
 End If 
i = 0 
对于每个varField在FieldList 
 OutputArray（1，iCol + i）= CStr（varField） 
i = i = 1 
下一个
如果
 
 ArrayToRange rngTarget.Cells（0，1），OutputArray 
 
 End If

End If'ShowFieldNames

擦除OutputArray

End Sub
'
公共函数ArrayTranspose（InputArray As Variant）As Variant
'Transpose InputArray。
'如果它不是二维变体（x，y），则返回InputArray不变的方式

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
退出函数
结束如果

如果InStr（1，TypeName（InputArray），（）< 1 Then
ArrayTranspose = InputArray
退出函数
结束如果

'检查我们可以读取数组的维度：
On Error Resume Next

  Err.Clear 
 iRowCount = 0 
 iRowCount = UBound（InputArray，1）
如果Err.Number<> 0然后
 boolNoRows = True 
 End If 
 Err.Clear 
 
 Err.Clear 
 iColCount = 0 
 iColCount = UBound（InputArray，2）
如果Err.Number<> 0然后
 BoolNoCols = True 
结束如果
 Err.Clear

如果boolNoRows然后

 '所有数组都有一个定义的Ubound（MyArray，1）！ 
'无法确定此变体的维度
 OutputArray = InputArray

ElseIf BoolNoCols Then

 '这是一个向量。严格来说，一个向量不能被转置，因为
'调用序号'row'或'column'是任意或无意义的。 
'但是...按照惯例，Excel用户将向量视为1到n 
'行和1列的数组。所以我们将'转置'变成一个变量（1到1，1到n）
 
 ReDim OutputArray（1到1，LBound（InputArray，1）到UBound（InputArray，1））
 
对于iRow = LBound（InputArray，1）到UBound（InputArray，1）
 
 OutputArray（1，iRow）= InputArray（iRow）
 
下一步iRow

其他

对于UBound（InputArray，2），LBound（InputArray，1）到UBound（InputArray，1））

如果IsEmpty（OutputArray）然后
ArrayTranspose = InputArray
退出函数
结束If

如果InStr（1，TypeName（OutputArray），（）< 1 Then
ArrayTranspose = InputArray
退出函数
如果

对于iRow = LBound（InputArray，1）到UBound（InputArray，1）
对于iCol = LBound（InputArray， 2）到UBound（InputArray，2）
OutputArray（iCol，iRow）= InputArray（iRow，iCol）
下一个iCol
下一个iRow
/ pre>

结束如果

ExitFunction：

  ArrayTranspose = OutputArray 
擦除OutputArray

结束功能

让我知道你如何得到。一如往常，注意格式化故障：我从来没有得到<代码>标签在这个网站上工作，< PRE>

Postscript：在Excel上运行SQLTable对象

为了完整，这里是准系统读取具有SQL'函数的Excel表对象的代码，用于处理后台中的所有文本文件黑客。

我现在发布了一下，原来的答案已经上升了一段时间，因为每个人都在Excel中使用丰富的table对象列表数据：

 
'在表上运行JOIN查询，并将字段名称和数据写入Sheet1：
 
 SaveTableTable1
 SaveTableTable2
 
 SQL = SQL& SELECT *
 SQL = SQL& FROM Table1
 SQL = SQL& LEFT JOIN Table2
 SQL = SQL& ON Table1.Client = Table2.Client
 
 RunSQL SQL，Sheet1.Range（A1）

我们都需要有时运行SQL;我希望Microsoft最终在Excel表上发布一个本机的RunSQL功能，因为SQL在连接，子查询和嵌套排序的所有尝试在VBA中变得呈指数级复杂时长时间保持简单 - 或者任何其他程序语言。

...完整列表（在以前的代码转储中给出或执行几个函数）是：

公共函数RunSQL（SQL As String，TargetRange As Excel.Range，可选DataSetName As String）
'针对本地ExcelSQL文件夹中的表文件运行SQL，并将结果写入目标范围

'完全实现ExcelSQL在控制页面上提供了一个功能齐全的UI
'这是一个自动运行所有操作的剪切版本，无需审核。错误报告

'可以使用ReadRangeSQL函数从范围读取SQL。

'如果没有传入目标范围对象，并且数据集名称为在本地Excel SQL文件夹中，记录集将
'保存为[DataSetName] .csv用于后续SQL查询

'如果未指定目标范围，并且未指定数据集名称，返回记录对象

Dim rst As ADODB.Recordset

如果剩下（SQL，4）=SQL_，然后
SQL = ReadRangeSQL（ ThisWorkbook.Names（SQL）.RefersToRange）
End If

设置rst = FetchTextRecordset（SQL）

如果TargetRange为Nothing然后

如果DataSetName =然后
设置RunSQL = rst
Else
RecordsetToCSV rst，DataSetName，，，，，，，False
设置rst = Nothing
如果

Else
RecordsetToRange rst，TargetRange，True
设置rst = Nothing
如果

结束函数

公共函数FetchTextRecordset（SQL As String）作为ADODB.Recordset
'从Temp SQL文件夹中保存的文本文件获取记录：

On Error Resume Next

Dim i As Integer
Dim iFrom As Integer

如果InStr（1，connText，IMEX = 1，vbTextCompare）> 0 Then SetSchema

设置FetchTextRecordset =新建ADODB.Recordset

使用FetchTextRecordset

.CacheSize = 8
设置.ActiveConnection = connText

On错误GoTo ERR_ADO
。打开SQL，，adOpenStatic，，adCmdText + adAsyncFetch

i = 0
Do While .State> 1
i =（i + 1）Mod 3
Application.StatusBar =等待数据& String（i，。）
Application.Wait Now +（0.25 / 24/3600）
循环

结束与

Application.StatusBar = False

ExitSub：
退出函数

ERR_ADO：

Dim strMsg

strMsg = vbCrLf& vbCrLf& 如果这是一个文件错误，有人有一个源数据文件打开：几分钟后再试一次。 &安培; vbCrLf& vbCrLf& 否则，请记下此错误信息，并与开发人员联系，或&支持&
如果Verbose然后
MsgBoxError& H&十六进制（Err.Number）& ：&错误描述& strMsg，vbCritical + vbMsgBoxHelpButton，数据检索错误：，Err.HelpFile，Err.HelpContext
End If
恢复ExitSub

退出函数

'如果SQL太大而无法在立即窗口中调试，请尝试此操作：
'FSO.OpenTextFile（C：\Temp\SQL.txt，ForWriting，True）.Write SQL
'ShellNotepad.exe C：\Temp\SQL.txt，vbNormalFocus
'简历
结束功能

私有属性获取connText（）作为ADODB.Connection
错误GoTo ErrSub

Dim strTempFolder

如果m_objConnText没有，然后

 设置m_objConnText =新的ADODB.Connection 
 
 strTempFolder = TempSQLFolder'这将测试是否该文件夹允许SQL READ操作
 
 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& 扩展属性=& Chr（34）& text; CharacterSet = UNICODE; HDR = Yes; HDR = Yes; IMEX = 1; MaxScanRows = 1& Chr（34）& ;

结束如果

如果不是m_objConnText没有，那么

 使用m_objConnText 
 
如果.State = adStateClosed然后
 
 Application.StatusBar =连接到本地Excel表
 .CursorLocation = adUseClient 
 .CommandTimeout = 90 
 .ConnectionString = m_strConnText 
 .Mode = adModeRead 
 .Open 
 
 End If 
 
结束
 
如果m_objConnText.State = adStateClosed然后
设置m_objConnText =没有
结束如果

结束如果

设置connText = m_objConnText

ExitSub：
Application.StatusBar = False
退出属性

ErrSub：
MsgBox连接到Excel本地数据时出错请联系&支持& 。，vbCritical + vbApplicationModal，数据库连接失败！，10
恢复ErrEnd
'恢复ExitSub
ErrEnd：
结束'终端错误。停。
结束属性

公共Sub CloseConnections（）

错误恢复下一步

Set m_objConnText = Nothing

End Sub

公共功能TempSQLFolder ）As String
Application.Volatile False

'SQL文本数据函数使用的临时表文件的位置
'还运行后台进程清除超过7天的文件

'最好的位置是用户临时文件夹中的一个命名子文件夹。
'user local'temp'文件夹可以在所有的Windows系统上使用
'GetObject（Scripting.FileSystemObject）。GetSpecialFolder（2）.ShortPath
'，通常为C： \用户[用户名] \AppData\Local\Temp

'依赖关系：
'功能TestSQLFolder（），测试文件夹可用，一次。
'对象属性FSO（返回Scripting.FilesystemObject）
'

Dim strCMD As String
Dim strMsg As String
Dim strNamedFolder As String
静态strTempFolder As String'Cache it
Dim iRetry As Integer
Dim i As Long

'如果我们' ve已经找到一个可用的临时文件夹，使用静态值
'而不查询文件系统并再次测试写权限：
如果strTempFolder <$
TempSQLFolder = strTempFolder
退出函数
结束如果

On Error Resume Next

iRetry = 0

重试：
iRetry = iRetry + 1

选择案例iRetry
案例1
strNamedFolder =[Temp]
案例2
strNamedFolder =[应用程序数据]
案例3
strNamedFolder =[我的文档]
案例4
strNamedFolder =[Home]
案例4
strNamedFolder =C ：\Temp
Case Else

  strMsg =The& APP_NAME& 应用程序由于安全设置不良而无法使用。 
 strMsg = strMsg& vbCrLf& vbCrLf 
 strMsg = strMsg& 该程序需要从以下文件夹中的至少一个读取，写入和加载组件：
 strMsg = strMsg& vbCrLf 
 strMsg = strMsg& vbCrLf& •& 你的家庭驱动器：& vbTab& ExpandStandardFolders（[Home]）
 strMsg = strMsg& vbCrLf& •& [我的文件]
 strMsg = strMsg& vbCrLf& •& 申请资料：& ExpandStandardFolders（[Application Data]）
 strMsg = strMsg& vbCrLf& •& 你的Temp文件夹：& ExpandStandardFolders（[Temp]）
 strMsg = strMsg& vbCrLf& vbCrLf 
 strMsg = strMsg& 如果你可以使任何一个这些位置是可信赖的位置
 strMsg = strMsg& 使用Microsoft Excel信托中心文件>选项>信任中心，
 strMsg = strMsg& 那么应用程序将能够运行。 
 strMsg = strMsg& vbCrLf& vbCrLf 
 strMsg = strMsg& 或者，您可以联系系统管理员。 
 
选择案例MsgBox（strMsg，vbCritical + vbRetryCancel，APP_NAME&：请检查您的安全设置。）
案例vbRetry 
 iRetry = 0 
 GoTo重试
 Case Else 
 Application.StatusBar =该应用程序当前在此工作站上不可用，请更改您的安全设置。 
 Application.EnableEvents = True 
 Application.ScreenUpdating = True 
结束
结束选择
 
退出函数

结束选择

  strTempFolder = ExpandStandardFolders（strNamedFolder） 
 
如果右（strTempFolder，1）<> \然后
 strTempFolder = strTempFolder& \
如果
 
 strTempFolder = strTempFolder& XLSQL
 
如果不是FSO.FolderExists（strTempFolder）然后
 FSO.CreateFolder strTempFolder 
如果
i = 1 
直到FSO.FolderExists（ strTempFolder）或我> 6 
睡眠我* 250 
 Application.StatusBar =等待SQL缓存文件夹& String（i Mod 4，。）
循环
 
如果不是FSO.FolderExists（strTempFolder）然后
 GoTo重试
如果
 
如果右（strTempFolder，1）<> \然后
 strTempFolder = strTempFolder& \
如果

TempSQLFolder = strTempFolder

如果TestSQLFolder = False然后
strTempFolder =
GoTo Retry'我知道。这被认为是有害的。
结束如果

Application.StatusBar = False

结束功能

私有函数TestSQLFolder（）As Boolean

'如果我们可以在TempSQLFolder
中写入一个文件，那么返回TRUE，并将其读为一个表与SQL

On Error Resume Next
Dim strConn As String
Dim strFile As String
Dim strName As String

Dim i As Integer

strName = FSO.GetTempName
ReplaceExtension strName, \".csv\" $b$ b strFile = TempSQLFolder & strName

StringToCsv Chr(34) & \"TestSQL\" & Chr（34）& vbCrLf& \"1\" & vbCrLf& 2& vbCrLf& \"3\", strName, , , , , False

i = 1
Do Until FSO.FileExists(strFile) Or i > 6
Sleep i * 250
Application.StatusBar = \"Testing SQL cache folder\" & String(i Mod 4, \".\")
Loop

If Not FSO.FileExists(strFile) Then
TestSQLFolder = False
Else

Application.StatusBar = \"Testing XL SQL cache function...\" 
  
 ’ MS-Access ACE OLEDB Provider

strConn = \"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=\" & Chr（34）& TempSQLFolder & Chr（34）& \";Persist Security Info=True;\"
strConn = strConn & \"Extended Properties=\" & Chr（34）& \"text;CharacterSet=UNICODE;HDR=Yes;HDR=Yes;IMEX=1;MaxScanRows=1\" & Chr（34）& \";\"

With New ADODB.Recordset
.Open \"SELECT COUNT([TestSQL]) AS T1 FROM [\" & strName & \"]\", strConn, adOpenStatic, , adCmdText
i = 0
i = .Fields(0).Value
If i = 0 Then
i = Len(.Fields(0).Name)
End If
.Close
End With

If i = 0 Then 
     TestSQLFolder = False 
 Else 
     TestSQLFolder = True 
 End If 
  
 FSO.DeleteFile strFile, True

End If

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.

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?

解决方案

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< BR />

It's a little bit clumsy, forcing you to name the tables (or list the range addresses in full) when you run the query, but doing it this way 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 problems when multiple instances of the Excel application
' are running, so we use a text driver to read csv files in a temporary folder. These files
' are populated 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(Scripting.TemporaryFolder).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.

Dim i As Integer
Dim j As Integer
Dim arrRows As Variant
Dim strRow As String

arrRows = SQL_Range.Value2

If InStr(TypeName(arrRows), "(") Then
For i = LBound(arrRows, 1) To UBound(arrRows, 1)

    strRow = ""

    For j = LBound(arrRows, 2) To UBound(arrRows, 2)

        If Trim(arrRows(i, j)) = "" Then
            arrRows(i, j) = "    "
        End If
        strRow = strRow & arrRows(i, j)

    Next j

    strRow = RTrim(strRow)
    If strRow <> "" Then
        ReadRangeSQL = ReadRangeSQL & strRow & vbCrLf
    End If

Next i

Erase arrRows
Else
    ReadRangeSQL = CStr(arrRows)
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

' Note that 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), " ")        ' removing line breaks is not RFC 4180 compliant
            strData = Replace(strData, Chr(13), " ")        ' ...but the Excel driver will break if we don't
            strData = Replace(strData, Chr(9), " ")
            strData = Trim(strData)
        End If
        strData = Chr(34) & strData & Chr(34) & ","         ' Enclosing by quotes coerces 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, and it's something you're going to be doing a lot:

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.

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")

We all need to run SQL sometimes; and I hope that Microsoft eventually releases a native 'RunSQL on Excel Tables' function, because SQL stays simple long after all attempts at joins, subqueries and nested sorting become exponentially complex in VBA - or in any other procedural language.

...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:
'   Function TestSQLFolder(), tests folder is usable, once.
'   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

iRetry = 0

Retry:
iRetry = iRetry + 1

Select Case iRetry
Case 1
    strNamedFolder = "[Temp]"
Case 2
    strNamedFolder = "[Application Data]"
Case 3
    strNamedFolder = "[My Documents]"
Case 4
    strNamedFolder = "[Home]"
Case 4
    strNamedFolder = "C:\Temp"
Case Else
strMsg = "The " & APP_NAME & " application is unusable due to a bad security setting."
strMsg = strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "This program needs to read, write, and load components from at least one of these folders:"
strMsg = strMsg & vbCrLf
strMsg = strMsg & vbCrLf & "• " & "Your Home drive:  " & vbTab & ExpandStandardFolders("[Home]")
strMsg = strMsg & vbCrLf & "• " & "[My Documents]"
strMsg = strMsg & vbCrLf & "• " & "Application Data: " & ExpandStandardFolders("[Application Data]")
strMsg = strMsg & vbCrLf & "• " & "Your Temp folder: " & ExpandStandardFolders("[Temp]")
strMsg = strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "If you can make any one of these locations a 'Trusted Location' "
strMsg = strMsg & "using the Microsoft Excel Trust Center under 'File > Options > Trust Center',"
strMsg = strMsg & " then the application will be able to function."
strMsg = strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "Alternatively, you can contact your system administrator."

Select Case MsgBox(strMsg, vbCritical + vbRetryCancel, APP_NAME & ": Please check your security settings.")
Case vbRetry
    iRetry = 0
    GoTo Retry
Case Else
    Application.StatusBar = "The application is currently unusable on this workstation. Change your security settings."
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    End
End Select

Exit Function
End Select
strTempFolder = ExpandStandardFolders(strNamedFolder)

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

If TestSQLFolder = False Then
    strTempFolder = ""
    GoTo Retry    ' I know. It's considered harmful.
End If

Application.StatusBar = False

End Function

Private Function TestSQLFolder() As Boolean

' Return TRUE if we can write a file in TempSQLFolder
' and read it as a table with SQL

On Error Resume Next
Dim strConn As String
Dim strFile As String
Dim strName As String

Dim i As Integer

strName = FSO.GetTempName
ReplaceExtension strName, ".csv"
strFile = TempSQLFolder & strName

StringToCsv Chr(34) & "TestSQL" & Chr(34) & vbCrLf & "1" & vbCrLf & "2" & vbCrLf & "3", strName, , , , , False

i = 1
Do Until FSO.FileExists(strFile) Or i > 6
    Sleep i * 250
    Application.StatusBar = "Testing SQL cache folder" & String(i Mod 4, ".")
Loop

If Not FSO.FileExists(strFile) Then
    TestSQLFolder = False
Else
Application.StatusBar = "Testing XL SQL cache function..."

' MS-Access ACE OLEDB Provider
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & TempSQLFolder & Chr(34) & ";Persist Security Info=True;"
   strConn = strConn & "Extended Properties=" & Chr(34) & "text;CharacterSet=UNICODE;HDR=Yes;HDR=Yes;IMEX=1;MaxScanRows=1" & Chr(34) & ";"

With New ADODB.Recordset
        .Open "SELECT COUNT([TestSQL]) AS T1 FROM [" & strName & "]", strConn, adOpenStatic, , adCmdText
        i = 0
        i = .Fields(0).Value
        If i = 0 Then
            i = Len(.Fields(0).Name)
        End If
        .Close
   End With
If i = 0 Then
    TestSQLFolder = False
Else
    TestSQLFolder = True
End If

FSO.DeleteFile strFile, True
End If

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.

这篇关于excel vba - 在电子表格上查询的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文

excel vba - 在电子表格上查询 [英] excel vba - query on a spreadsheet

问题描述

Postscript：在Excel上运行SQLTable对象

Postscript: Running SQL on Excel 'Table' Objects

相关文章

Office最新文章

热门教程

热门工具

登录关闭

excel vba - 在电子表格上查询 [英] excel vba - query on a spreadsheet

问题描述

Postscript：在Excel上运行SQLTable对象

Postscript: Running SQL on Excel 'Table' Objects

相关文章

Office最新文章

热门教程

热门工具

登录 关闭

登录关闭