excel vba - 在电子表格上查询

本文介绍了excel vba - 在电子表格上查询的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！ 问题描述 29岁程序员，3月因学历无情被辞！ 如果我有这两个表： 是否有某种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 ElseApplication.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 WithIf 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 ExplicitOption 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.tlbPrivate m_strTempFolder As StringPrivate m_strConXL As StringPrivate m_objConnXL As ADODB.ConnectionPublic Property Get XLConnection() As ADODB.ConnectionOn 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.FileSystemObjectSet objFSO = New Scripting.FileSystemObjectSet m_objConnXL = New ADODB.Connection' Specify and clear a temporary folder:m_strTempFolder = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPathIf Right(m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder & "\"End Ifm_strTempFolder = m_strTempFolder & "XLSQL"Application.DisplayAlerts = FalseIf objFSO.FolderExists(m_strTempFolder) Then objFSO.DeleteFolder m_strTempFolderEnd IfIf Not objFSO.FolderExists(m_strTempFolder) Then objFSO.CreateFolder m_strTempFolderEnd IfIf 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 = adModeReadEnd WithIf m_objConnXL.State = adStateClosed Then Application.StatusBar = "Connecting to the local Excel tables" m_objConnXL.OpenEnd IfSet XLConnection = m_objConnXLExitSub: Application.StatusBar = False Exit PropertyErrSub: MsgPopup "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10 Resume ErrEnd ' Resume ExitSubErrEnd: End ' Terminal error. Halt.End PropertyPublic Sub CloseConnections()On Error Resume NextSet m_objConnXL = NothingEnd SubPublic 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#20On Error Resume NextDim i As IntegerDim iFrom As IntegerDim strRange As StringDim j As IntegerDim k As IntegerIf IsEmpty(TableNames) Then TableNames = Array("")End IfIf InStr(TypeName(TableNames), "(") < 1 Then TableNames = Array(TableNames)End IfSet FetchXLRecordSet = New ADODB.RecordsetWith FetchXLRecordSet.CacheSize = 8Set .ActiveConnection = XLConnectioniFrom = InStr(8, SQL, "From", vbTextCompare) + 4For 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 + adAsyncFetchi = 0Do While .State > 1 i = (i + 1) Mod 3 Application.StatusBar = "Connecting to the database" & String(i, ".") Sleep 250LoopEnd WithApplication.StatusBar = FalseEnd FunctionPublic 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 IntegerDim j As IntegerDim arrRows As VariantDim strRow As StringarrRows = SQL_Range.Value2If InStr(TypeName(arrRows), "(") ThenFor 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 IfNext iErase arrRowsElse ReadRangeSQL = CStr(arrRows)End IfEnd FunctionPublic 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 NextDim objFSO As Scripting.FileSystemObjectDim rng As Excel.RangeDim strFile As StringDim arrData As VariantDim iRow As LongDim jCol As LongDim strData As StringDim strLine As StringstrRange = Replace(strRange, "[", "")strRange = Replace(strRange, "]", "")If Right(strRange, 1) = "$" Then strRange = Replace(strRange, "$", "") Set rng = ThisWorkbook.Worksheets(strRange).UsedRangeElse strRange = Replace(strRange, "$", "") Set rng = Range(strRange)If rng Is Nothing Then Set rng = ThisWorkbook.Worksheets(strRange).UsedRangeEnd IfEnd IfIf rng Is Nothing Then Exit SubEnd IfSet objFSO = New Scripting.FileSystemObjectstrFile = m_strTempFolder & strRange & ".csv"If objFSO.FileExists(strFile) Then objFSO.DeleteFile strFile, TrueEnd IfIf objFSO.FileExists(strFile) Then Exit SubEnd IfarrData = rng.Value2With 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 & strDataNext jColstrLine = Left(strLine, Len(strLine) - 1) ' Trim trailing commaIf Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .WriteLine strLineEnd If' Rest of the dataFor 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 IfNext iRow.CloseEnd With ' textstream object from objFSO.OpenTextFileSet objFSO = NothingErase arrDataSet rng = NothingEnd SubAnd 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 NextDim OutputArray As VariantDim i As IntegerDim iCol As IntegerDim iRow As IntegerDim varField As VariantIf objRecordset Is Nothing Then Exit SubEnd IfIf objRecordset.State <> 1 Then Exit SubEnd IfIf objRecordset.BOF And objRecordset.EOF Then Exit SubEnd IfIf Orientation = xlColumns Then If IsEmpty(FieldList) Or IsMissing(FieldList) Then OutputArray = objRecordset.GetRows Else OutputArray = objRecordset.GetRows(Fields:=FieldList) End IfElse If IsEmpty(FieldList) Or IsMissing(FieldList) Then OutputArray = ArrayTranspose(objRecordset.GetRows) Else OutputArray = ArrayTranspose(objRecordset.GetRows(Fields:=FieldList)) End IfEnd IfArrayToRange rngTarget, OutputArrayIf ShowFieldNames ThenIf 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), OutputArrayElse 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), OutputArrayEnd IfEnd If 'ShowFieldNamesErase OutputArrayEnd 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 LongDim iCol As LongDim iRowCount As LongDim iColCount As LongDim boolNoRows As BooleanDim BoolNoCols As BooleanDim OutputArray As VariantIf IsEmpty(InputArray) Then ArrayTranspose = InputArray Exit FunctionEnd IfIf InStr(1, TypeName(InputArray), "(") < 1 Then ArrayTranspose = InputArray Exit FunctionEnd If' Check that we can read the array's dimensions:On Error Resume NextErr.CleariRowCount = 0iRowCount = UBound(InputArray, 1)If Err.Number <> 0 Then boolNoRows = TrueEnd IfErr.ClearErr.CleariColCount = 0iColCount = UBound(InputArray, 2)If Err.Number <> 0 Then BoolNoCols = TrueEnd IfErr.ClearIf boolNoRows Then' ALL arrays have a defined Ubound(MyArray, 1)!' This variant's dimensions cannot be determined OutputArray = InputArrayElseIf 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 iRowElseReDim OutputArray(LBound(InputArray, 2) To UBound(InputArray, 2), LBound(InputArray, 1) To UBound(InputArray, 1))If IsEmpty(OutputArray) Then ArrayTranspose = InputArray Exit FunctionEnd IfIf InStr(1, TypeName(OutputArray), "(") < 1 Then ArrayTranspose = InputArray Exit FunctionEnd IfFor iRow = LBound(InputArray, 1) To UBound(InputArray, 1) For iCol = LBound(InputArray, 2) To UBound(InputArray, 2) OutputArray(iCol, iRow) = InputArray(iRow, iCol) Next iColNext iRowEnd IfExitFunction:ArrayTranspose = OutputArrayErase OutputArrayEnd FunctionLet 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' ObjectsFor 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 objectDim rst As ADODB.RecordsetIf Left(SQL, 4) = "SQL_" Then SQL = ReadRangeSQL(ThisWorkbook.Names(SQL).RefersToRange)End IfSet rst = FetchTextRecordset(SQL)If TargetRange Is Nothing Then If DataSetName = "" Then Set RunSQL = rst Else RecordsetToCSV rst, DataSetName, , , , , , , False Set rst = Nothing End IfElse RecordsetToRange rst, TargetRange, True Set rst = NothingEnd IfEnd FunctionPublic Function FetchTextRecordset(SQL As String) As ADODB.Recordset' Fetch records from the saved text files in the Temp SQL Folder:On Error Resume NextDim i As IntegerDim iFrom As IntegerIf InStr(1, connText, "IMEX=1", vbTextCompare) > 0 Then SetSchemaSet FetchTextRecordset = New ADODB.RecordsetWith 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) LoopEnd WithApplication.StatusBar = FalseExitSub: Exit FunctionERR_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 ExitSubExit 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'ResumeEnd FunctionPrivate Property Get connText() As ADODB.ConnectionOn Error GoTo ErrSubDim strTempFolderIf m_objConnText Is Nothing ThenSet m_objConnText = New ADODB.ConnectionstrTempFolder = TempSQLFolder ' this will test whether the folder permits SQL READ operationsApplication.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 IfIf Not m_objConnText Is Nothing ThenWith 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 IfEnd WithIf m_objConnText.State = adStateClosed Then Set m_objConnText = NothingEnd IfEnd IfSet connText = m_objConnTextExitSub: Application.StatusBar = False Exit PropertyErrSub: MsgBox "Error connecting to the Excel local data. Please contact " & SUPPORT & ".", vbCritical + vbApplicationModal, "Database connection failure!", 10 Resume ErrEnd ' Resume ExitSubErrEnd: End ' Terminal error. Halt.End PropertyPublic Sub CloseConnections()On Error Resume NextSet m_objConnText = NothingEnd SubPublic Function TempSQLFolder() As StringApplication.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 StringDim strMsg As StringDim strNamedFolder As StringStatic strTempFolder As String ' Cache itDim iRetry As IntegerDim 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 FunctionEnd IfOn Error Resume NextiRetry = 0Retry:iRetry = iRetry + 1Select Case iRetryCase 1 strNamedFolder = "[Temp]"Case 2 strNamedFolder = "[Application Data]"Case 3 strNamedFolder = "[My Documents]"Case 4 strNamedFolder = "[Home]"Case 4 strNamedFolder = "C:\Temp"Case ElsestrMsg = "The " & APP_NAME & " application is unusable due to a bad security setting."strMsg = strMsg & vbCrLf & vbCrLfstrMsg = strMsg & "This program needs to read, write, and load components from at least one of these folders:"strMsg = strMsg & vbCrLfstrMsg = 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 & vbCrLfstrMsg = 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 & vbCrLfstrMsg = 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 RetryCase Else Application.StatusBar = "The application is currently unusable on this workstation. Change your security settings." Application.EnableEvents = True Application.ScreenUpdating = True EndEnd SelectExit FunctionEnd SelectstrTempFolder = ExpandStandardFolders(strNamedFolder)If Right(strTempFolder, 1) <> "\" Then strTempFolder = strTempFolder & "\"End IfstrTempFolder = strTempFolder & "XLSQL"If Not FSO.FolderExists(strTempFolder) Then FSO.CreateFolder strTempFolderEnd Ifi = 1Do Until FSO.FolderExists(strTempFolder) Or i > 6 Sleep i * 250 Application.StatusBar = "Waiting for SQL cache folder" & String(i Mod 4, ".")LoopIf Not FSO.FolderExists(strTempFolder) Then GoTo RetryEnd IfIf Right(strTempFolder, 1) <> "\" Then strTempFolder = strTempFolder & "\"End IfTempSQLFolder = strTempFolderIf TestSQLFolder = False Then strTempFolder = "" GoTo Retry ' I know. It's considered harmful.End IfApplication.StatusBar = FalseEnd FunctionPrivate Function TestSQLFolder() As Boolean' Return TRUE if we can write a file in TempSQLFolder' and read it as a table with SQLOn Error Resume NextDim strConn As StringDim strFile As StringDim strName As StringDim i As IntegerstrName = FSO.GetTempNameReplaceExtension strName, ".csv"strFile = TempSQLFolder & strNameStringToCsv Chr(34) & "TestSQL" & Chr(34) & vbCrLf & "1" & vbCrLf & "2" & vbCrLf & "3", strName, , , , , Falsei = 1Do Until FSO.FileExists(strFile) Or i > 6 Sleep i * 250 Application.StatusBar = "Testing SQL cache folder" & String(i Mod 4, ".")LoopIf Not FSO.FileExists(strFile) Then TestSQLFolder = FalseElseApplication.StatusBar = "Testing XL SQL cache function..."' MS-Access ACE OLEDB ProviderstrConn = "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 WithIf i = 0 Then TestSQLFolder = FalseElse TestSQLFolder = TrueEnd IfFSO.DeleteFile strFile, TrueEnd IfApplication.StatusBar = FalseEnd FunctionPublic Property Get FSO() As Scripting.FileSystemObject '' Return a File System ObjectOn Error Resume NextIf m_objFSO Is Nothing Then Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObjectEnd IfIf m_objFSO Is Nothing Then Shell "Regsvr32.exe /s scrrun.dll", vbHide Set m_objFSO = CreateObject("Scripting.FileSystemObject")End IfSet FSO = m_objFSOEnd PropertyPublic 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 tablesDim wks As Excel.WorksheetDim oList As Excel.ListObjectDim sFile As StringDim bAsync As BooleanIf TableName = "*" Then bAsync = TrueElse bAsync = FalseEnd IfFor 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 oListNext wksSetSchemaEnd SubPublic 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.WorksheetDim oList As Excel.ListObjectDim sFile As StringDim sFolder As StringsFolder = TempSQLFolderFor 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 IfNext oListNext wksEnd SubShare 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 - 在电子表格上查询的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！ 上岸，阿里云！