excel vba – 在电子表格上查询

如果我有这两个表：

资源

目标

SQL

结果

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

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

在我完整发布代码之前，核心函数FetchXLRecordSet中的原始“样例用法”注释如下 ： 

 '样本用法：
 “
 'Set rst = FetchXLRecordSet（SQL，“TableAccountLookup”，“TableCashMap”）
 “
 '查询使用两个命名范围，“TableAccountLookup”和“TableCashMap”
 '在这个SQL语句中显示：
 “
 ' select
 B.Legal_Entity_Name，B.Status，
 'SUM（A.USD_Settled）As Settled_Cash
 '从
 '[TableAccountLookup] AS A，
 '[TableCashMap] AS B
 '在哪里
 A.Account不是NULL
 '和B.Cash_Account不是NULL
 '和A.帐户= B.Cash_Account
 ' 通过...分组
 “B.Legal_Entity_Name，
 B.Status

它很笨重，强制你在运行查询时命名表（或者列出范围地址），但是它简化了代码。 

选项显式
选件专用模块 

 'ADODB数据检索function支持Excel 

 '连接string的在线参考：
 ' 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作为string
私人m_strConXL作为string
私人m_objConnXL作为ADODB.Connection 


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

 “Excel数据库驱动程序有内存问题，所以我们使用文本驱动程序
 '读取临时文件夹中的csv文件。 我们从这些文件中填充
 '范围指定用作FetchXLRecordSet（）函数的表。 


 Dim objFSO As Scripting.FileSystemObject 


设置objFSO =新buildScripting.FileSystemObject
设置m_objConnXL =新的ADODB.Connection 

     '指定并清除临时文件夹： 


     m_strTempFolder = objFSO.GetSpecialFolder（2）.ShortPath 


    如果右（m_strTempFolder，1）<>“\”那么
         m_strTempFolder = m_strTempFolder＆“\”
    万一 


     m_strTempFolder = m_strTempFolder＆“XLSQL” 


     Application.DisplayAlerts = False 

    如果objFSO.FolderExists（m_strTempFolder）那么
         objFSO.DeleteFolder m_strTempFolder
    万一 

    如果不是objFSO.FolderExists（m_strTempFolder）那么
         objFSO.CreateFolder m_strTempFolder
    万一 


    如果右（m_strTempFolder，1）<>“\”那么
         m_strTempFolder = m_strTempFolder＆“\”
    万一 



 JET OLEDB文本驱动程序连接string：
 'Provider = Microsoft.Jet.OLEDB.4.0; Data Source = c：\ txtFilesFolder \; Extended Properties =“text; HDR = Yes; FMT = Delimited”; 

 'ODBC文本驱动程序连接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＆”;“
     ＆lt; m_strConXL = m_strConXL＆“Extended Properties =”＆Chr（34）＆“text; HDR = Yes; IMEX = 1”＆Chr（34）＆“;” 
 
    用m_objConnXL
         .CursorLocation = adUseClient
         .CommandTimeout = 90
         .ConnectionString = m_strConXL
         .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：
    结束'terminal错误。 停。
最终财产 


 Public Sub CloseConnections（） 

在错误恢复下一步 

设置m_objConnXL = Nothing 

结束小组 


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

 '请注意，您的查询必须使用Excel所需的'表'命名约定
 '数据库驱动程序： http ： //www.connectionstrings.com/excel#20 

在错误恢复下一步 

昏暗我作为整数
昏暗的iFrom整数
昏暗strRange作为string
 Dim j As Integer
 Dim k As Integer 

如果IsEmpty（TableNames）那么
     TableNames = Array（“”）
万一 

如果InStr（TypeName（TableNames），“（”）<1 Then
     TableNames = Array（TableNames）
万一 


设置FetchXLRecordSet =新的ADODB.Recordset 

用FetchXLRecordSet 


     .CacheSize = 8
    设置.ActiveConnection = XLConnection 


     iFrom = InStr（8，SQL，“From”，vbTextCompare）+ 4 


    对于我= 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，k  -  j  -  1）
        万一 


         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”） 


    接下来我 


     。打开SQL，adOpenStatic，adCmdText + adAsyncFetch 

    我= 0
    做的时候。状态> 1
         i =（i + 1）Mod 3
         Application.StatusBar =“连接到数据库”＆String（i，“。”）
        睡250
    循环 


结束 

 Application.StatusBar = False 

结束function 


公共函数ReadRangeSQL（SQL_Range As Excel.Range）作为string
 '将一个范围读入一个string。
 '每行用回车符和换行符分隔。
 '空单元格作为四个空格的“制表符”连接在string中。 

昏暗我作为整数
 Dim j As Integer
昏暗arrRows作为变种
昏暗strRow作为string 

 arrRows = SQL_Range.Value2 

如果InStr（TypeName（arrRows），“（”）那么 

    对于I = LBound（arrRows，1）到UBound（arrRows，1） 


         strRow =“” 


        对于j = LBound（arrRows，2）到UBound（arrRows，2） 


            如果修剪（arrRows（i，j））=“”那么
                 arrRows（i，j）=“”
            万一
             strRow = strRow＆arrRows（i，j） 


        下一个j 


         strRow = RTrim（strRow）
        如果strRow <>“”那么
             ReadRangeSQL = ReadRangeSQL＆strRow＆vbCrLf
        万一 


    接下来我 

    擦除arrRows 


其他
     ReadRangeSQL = CStr（arrRows）
万一 

结束function 


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

 '范围的第一行被假定为一组列名称。 

在错误恢复下一步 

 Dim objFSO As Scripting.FileSystemObject 

 Dim rng As Excel.Range
 Dim strFile As String
 Dim arrData As Variant
昏暗的iRow只要
昏暗的jCol只要
 Dim strData As String
昏暗strLine作为string 

 strRange = Replace（strRange，“[”，“”）
 strRange = Replace（strRange，“]”，“”） 

如果右（strRange，1）=“$”那么
     strRange = Replace（strRange，“$”，“”）
    设置rng = ThisWorkbook.Worksheets（strRange）.UsedRange
其他
     strRange = Replace（strRange，“$”，“”）
    设置rng = Range（strRange） 


    如果rng没有那么
        设置rng = ThisWorkbook.Worksheets（strRange）.UsedRange
    万一 

万一 

如果rng没有那么
    退出小组
万一 


设置objFSO =新buildScripting.FileSystemObject
 strFile = m_strTempFolder＆strRange＆“.csv” 

如果objFSO.FileExists（strFile）那么
     objFSO.DeleteFile strFile，True
万一 

如果objFSO.FileExists（strFile）那么
    退出小组
万一 

 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 = Replace（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（Replace（Replace（strLine，Chr（34），“”），“，”，“”））> 0 Then
         .WriteLine strLine
    万一 


    其余的数据
    对于iRow = LBound（arrData，1）+ 1到UBound（arrData，1） 


         strLine =“”
         strData =“” 


        对于jCol = LBound（arrData，2）到UBound（arrData，2）
            如果IsError（arrData（iRow，jCol））那么
                 strData =“#ERROR”
            其他
                 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）
            万一
             strData = Chr（34）＆strData＆Chr（34）＆“，”'引用强制所有值为文本
             strLine = strLine＆strData
        下一个jCol 


         strLine = Left（strLine，Len（strLine） -  1）'修剪尾随逗号 

        如果Len（Replace（Replace（strLine，Chr（34），“”），“，”，“”））> 0 Then
             .WriteLine strLine
        万一 

    下一个iRow 


 。关
结束使用来自objFSO.OpenTextFile的文本stream对象 

设置objFSO = Nothing
擦除arrData
设置rng =无 

结束小组

最后，将一个logging集写入一个范围 – 如果不是你必须处理的所有错误，代码将是微不足道的： 

公共子RecordsetToRange（rngTarget作为Excel.Range，objRecordset作为ADODB.Recordset，可选的FieldList作为变种，可选的ShowFieldNames作为布尔=假，可选的方向为Excel.XlRowCol = xlRows）
 '将一个ADOlogging集写入一个Excel范围，然后单击'打'到表单中
 '调用函数负责设置logging指针（不能是EOF！） 

 '目标范围自动调整到数组的大小，以左上angular的单元格作为起点。 

在错误恢复下一步 

 Dim OutputArray As Variant
昏暗我作为整数
昏暗的iCol作为整数
昏暗的iRow整数
 Dim varField As Variant 

如果objRecordset没有那么
  退出小组
万一 

如果objRecordset.State <> 1那么
  退出小组
万一 

如果objRecordset.BOF和objRecordset.EOF那么
    退出小组
万一 

如果Orientation = xlColumns Then
    如果IsEmpty（FieldList）或IsMissing（FieldList）那么
         OutputArray = objRecordset.GetRows
    其他
         OutputArray = objRecordset.GetRows（Fields：= FieldList）
    万一
其他
    如果IsEmpty（FieldList）或IsMissing（FieldList）那么
         OutputArray = ArrayTranspose（objRecordset.GetRows）
    其他
         OutputArray = ArrayTranspose（objRecordset.GetRows（Fields：= FieldList））
    万一
万一 

 ArrayToRange rngTarget，OutputArray 

如果ShowFieldNames那么 

    如果Orientation = xlColumns Then 

         ReDim OutputArray（LBound（OutputArray，1）To UBound（OutputArray，1），1 To 1） 

         iRow = LBound（OutputArray，1） 

        如果IsEmpty（FieldList）或IsMissing（FieldList）那么
             For i = 0 To objRecordset.Fields.Count  -  1
                如果我> UBound（OutputArray，1）然后
                    退出
                万一
                 OutputArray（iRow + i，1）= objRecordset.Fields（i）.Name
            接下来我
        其他
            如果InStr（TypeName（FieldList），“（”）<1 Then
                 FieldList = Array（FieldList）
            万一
            我= 0
            对于FieldList中的每个varField
                 OutputArray（iRow + i，1）= CStr（varField）
                我=我= 1
            下一个
        万一 

         ArrayToRange rngTarget.Cells（1，0），OutputArray 

    其他 

         ReDim OutputArray（1到1，LBound（OutputArray，2）到UBound（OutputArray，2）） 

         iCol = LBound（OutputArray，2） 

        如果IsEmpty（FieldList）或IsMissing（FieldList）那么
             For i = 0 To objRecordset.Fields.Count  -  1
                如果我> UBound（OutputArray，2）然后
                    退出
                万一
                 OutputArray（1，iCol + i）= objRecordset.Fields（i）.Name
            接下来我
        其他
            如果InStr（TypeName（FieldList），“（”）<1 Then
                 FieldList = Array（FieldList）
            万一
            我= 0
            对于FieldList中的每个varField
                 OutputArray（1，iCol + i）= CStr（varField）
                我=我= 1
            下一个
        万一 

         ArrayToRange rngTarget.Cells（0，1），OutputArray 

    万一 

结束如果'ShowFieldNames 

擦除OutputArray 

结束小组 


公共函数ArrayTranspose（InputArray As Variant）As Variant
 '转置InputArray。
如果InputArray不是二维变体（x，y），则返回InputArray 

昏暗的iRow只要
昏暗的iCol只要 

昏暗的iRowCount只要
昏暗的iColCount只要
昏暗boolNoRows作为布尔值
 Dim BoolNoCols As Boolean 

 Dim OutputArray As Variant 


如果IsEmpty（InputArray）那么
     ArrayTranspose = InputArray
    退出function
万一 

如果InStr（1，TypeName（InputArray），“（”）<1那么
     ArrayTranspose = InputArray
    退出function
万一 

 '检查我们是否可以读取数组的维度：
在错误恢复下一步 

     Err.Clear
     iRowCount = 0
     iRowCount = UBound（InputArray，1）
    如果Err.Number <> 0那么
         boolNoRows = True
    万一
     Err.Clear 

     Err.Clear
     iColCount = 0
     iColCount = UBound（InputArray，2）
    如果Err.Number <> 0那么
         BoolNoCols = True
    万一
     Err.Clear 


如果boolNoRows那么 

     '所有数组都有一个定义的Ubound（MyArray，1）！
     '这个变体的尺寸不能确定
      OutputArray = InputArray 

否则如果BoolNoCols那么 

     “这是一个vector。 严格来说，vector不能被“转置”，如
     “把序号称为”行“或”列“是任意的或无意义的。
     '但是...按照惯例，Excel用户将一个向量视为1到n的数组
     '行和1列。 所以我们将它转​​换成Variant（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 

其他 

     ReDim OutputArray（LBound（InputArray，2）到UBound（InputArray，2），LBound（InputArray，1）到UBound（InputArray，1）） 

    如果IsEmpty（OutputArray）那么
         ArrayTranspose = InputArray
        退出function
    万一 

    如果InStr（1，TypeName（OutputArray），“（”）<1 Then
         ArrayTranspose = InputArray
        退出function
    万一 

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

万一 


 ExitFunction： 

     ArrayTranspose = OutputArray
    擦除OutputArray 

结束function

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

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

为了完整起见，下面是准系统用SQL函数读取Excel表格对象的代码，该函数处理所有背景中的文本文件。

我现在发布它，一段时间后，我原来的答案上涨，因为每个人都使用丰富的“表”对象在Excel中的制表数据： 

 '在您的表上运行JOIN查询，并将字段名称和数据写入Sheet 1： 

 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”）

…完整的列表（在前面的代码转储中给出或者采取一些函数）是： 

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

 “ExcelSQL的完整实现在控制表上提供了全function的用户界面
 '这是一个自动运行所有内容的简化版本，无需审计和错误报告 


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

 '如果没有传入目标范围对象，并且指定了数据集名称，那么logging集将会是
 '保存为本地Excel SQL文件夹中的[DataSetName] .csv以供后续SQL查询使用 

 '如果没有指定目标范围并且没有指定数据集名称，则返回logging对象 


昏暗rst作为ADODB.Recordset 

如果Left（SQL，4）=“SQL_”那么
     SQL = ReadRangeSQL（ThisWorkbook.Names（SQL）.RefersToRange）
万一 


设置rst = FetchTextRecordset（SQL） 

如果TargetRange没有那么 

    如果DataSetName =“”那么
        设置RunSQL = rst
    其他
         RecordsetToCSV rst，DataSetName，，，，，，False
        设置rst = Nothing
    万一 


其他
     RecordsetToRange rst，TargetRange，True
    设置rst = Nothing
万一 

结束function 


公共职能FetchTextRecordset（SQL作为string）作为ADODB.Recordset
 '从Temp SQL文件夹中保存的文本文件中提取logging： 

在错误恢复下一步 

昏暗我作为整数
昏暗的iFrom整数 

如果InStr（1，connText，“IMEX = 1”，vbTextCompare）> 0然后SetSchema 

设置FetchTextRecordset =新的ADODB.Recordset 

使用FetchTextRecordset 

     .CacheSize = 8
    设置.ActiveConnection = connText 

    在错误转到ERR_ADO
     。打开SQL，adOpenStatic，adCmdText + adAsyncFetch 

    我= 0
    做的时候。状态> 1
         i =（i + 1）Mod 3
         Application.StatusBar =“等待数据”＆String（i，“。”）
         Application.Wait Now +（0.25 / 24/3600）
    循环 


结束 

 Application.StatusBar = False 


 ExitSub：
    退出function 


 ERR_ADO： 

昏暗strMsg 


     strMsg = vbCrLf＆vbCrLf＆“如果这是一个'文件'错误，某人有一个源数据文件打开：在几分钟内再试一次。  ＆vbCrLf＆vbCrLf＆“否则，请logging此错误消息并联系开发人员或”＆SUPPORT＆“。
    如果详细然后
         MsgBox“Error＆H”＆Hex（Err.Number）＆“：”＆Err.Description＆strMsg，vbCritical + vbMsgBoxHelpButton，“Data retrieval error：”，Err.HelpFile，Err.HelpContext
    万一
    恢复ExitSub 


退出function 


     '如果SQL太大而无法在直接窗口中进行debugging，请尝试以下操作：
     'FSO.OpenTextFile（“C：\ Temp \ SQL.txt”，ForWriting，True）.Write SQL
     'Shell'Notepad.exe C：\ Temp \ SQL.txt“，vbNormalFocus
 '恢复
结束function 


 Private Property获取connText（）作为ADODB.Connection
在错误转到ErrSub 

 Dim strTempFolder 

如果m_objConnText没有那么 


    设置m_objConnText =新的ADODB.Connection 

     strTempFolder = TempSQLFolder'这将testing文件夹是否允许SQL READ操作 


     Application.DisplayAlerts = False 


 “MS-Access ACE OLEDB提供程序”
    m_strConnText =“Provider = Microsoft.ACE.OLEDB.12.0; Data Source =”＆Chr（34）＆strTempFolder＆Chr（34）＆“; Persist Security Info = True;”
    （34）＆“text; CharacterSet = UNICODE; HDR = Yes; HDR = Yes; IMEX = 1; MaxScanRows = 1”＆Chr（34）＆“;”m_strConnText = m_strConnText＆ 


万一 

如果不是m_objConnText是没有的话 


    用m_objConnText 


        如果.State = adStateClosed那么 


             Application.StatusBar =“连接到本地Excel表”
             .CursorLocation = adUseClient
             .CommandTimeout = 90
             .ConnectionString = m_strConnText
             .Mode = adModeRead
             。打开 


        万一 


    结束 

    如果m_objConnText.State = adStateClosed那么
        设置m_objConnText = Nothing
    万一 


万一 

设置connText = m_objConnText 

 ExitSub：
     Application.StatusBar = False
    退出属性 


 ErrSub：
     MsgBox“连接到Excel本地数据时出错，请联系”＆SUPPORT＆“。”，vbCritical + vbApplicationModal，“数据库连接失败！”，10
    恢复ErrEnd
     '恢复ExitSub
 ErrEnd：
    结束'terminal错误。 停。
最终财产 


 Public Sub CloseConnections（） 

在错误恢复下一步 

设置m_objConnText = Nothing 

结束小组 


公共函数TempSQLFolder（）作为string
 Application.Volatile False 

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

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

 “依赖：
 'Function TestSQLFolder（），testing文件夹是可用的，一次。
 '对象属性FSO（返回Scripting.FilesystemObject）
 “ 

昏暗的strCMD作为string
昏暗strMsg作为string
 Dim strNamedFolder As String
静态strTempFolder作为string'caching它
昏暗iRetry作为整数
昏暗我只要 

 '如果我们已经find了一个可用的临时文件夹，请使用静态值
 '不查询文件系统并再次testing写入权限：
如果strTempFolder <>“”那么
     TempSQLFolder = strTempFolder
    退出function
万一 

在错误恢复下一步 

 iRetry = 0 

重试：
 iRetry = iRetry + 1 

select案例iRetry
情况1
     strNamedFolder =“[Temp]”
案例2
     strNamedFolder =“[应用程序数据]”
案例3
     strNamedFolder =“[我的文档]”
案例4
     strNamedFolder =“[Home]”
案例4
     strNamedFolder =“C：\ Temp”
其他情况 

     strMsg =“由于安全设置不正确，”＆APP_NAME＆“应用程序无法使用。”
     strMsg = strMsg＆vbCrLf＆vbCrLf
     strMsg = strMsg＆“这个程序需要从这些文件夹中的至less一个中读取，写入和加载组件：”
     strMsg = strMsg＆vbCrLf
     strMsg = strMsg＆vbCrLf＆“•”＆“Your Home drive：”＆vbTab＆ExpandStandardFolders（“[Home]”）
     strMsg = strMsg＆vbCrLf＆“？”＆“[我的文档]”
     strMsg = strMsg＆vbCrLf＆“•”＆“Application Data：”＆ExpandStandardFolders（“[Application Data]”）
     strMsg = strMsg＆vbCrLf＆“？”＆“您的临时文件夹：”＆ExpandStandardFolders（“[Temp]”）
     strMsg = strMsg＆vbCrLf＆vbCrLf
     strMsg = strMsg＆“如果您可以将这些位置中的任何一个设置为”可信位置“
     strMsg = strMsg＆“使用Microsoft Excel信任中心在”文件>选项>信任中心“，”
     strMsg = strMsg＆“那么应用程序将能够运行。”
     strMsg = strMsg＆vbCrLf＆vbCrLf
     strMsg = strMsg＆“或者，您可以联系您的系统pipe理员。” 


    select案例MsgBox（strMsg，vbCritical + vbRetryCancel，APP_NAME＆“：请检查您的安全设置。”）
    案例vbRetry
         iRetry = 0
        转到重试
    其他情况
         Application.StatusBar =“应用程序目前在这个工作站上不可用，请更改您的安全设置。
         Application.EnableEvents = True
         Application.ScreenUpdating = True
        结束
    结束select 


    退出function 


结束select 

     strTempFolder = ExpandStandardFolders（strNamedFolder） 


    如果右（strTempFolder，1）<>“\”然后
         strTempFolder = strTempFolder＆“\”
    万一 


     strTempFolder = strTempFolder＆“XLSQL” 


    如果不是FSO.FolderExists（strTempFolder）那么
         FSO.CreateFolder strTempFolder
    万一 

    我= 1
    直到FSO.FolderExists（strTempFolder）或i> 6
        睡眠我* 250
         Application.StatusBar =“等待SQLcaching文件夹”＆String（i Mod 4，“。”）
    循环 

    如果不是FSO.FolderExists（strTempFolder）那么
        转到重试
    万一 


    如果右（strTempFolder，1）<>“\”然后
         strTempFolder = strTempFolder＆“\”
    万一 



 TempSQLFolder = strTempFolder 


如果TestSQLFolder = False那么
     strTempFolder =“”
    去重试“我知道。 这被认为是有害的。
万一 

 Application.StatusBar = False 


结束function 


私人函数TestSQLFolder（）作为布尔值 

 '如果我们可以在TempSQLFolder中写入文件，则返回TRUE
 '并用SQL作为表格读取 

在错误恢复下一步
 Dim strConn As String
 Dim strFile As String
 Dim strName As String 

昏暗我作为整数 

 strName = FSO.GetTempName
 ReplaceExtension strName，“.csv”
 strFile = TempSQLFolder＆strName 

 StringToCsv Chr（34）＆“TestSQL”＆Chr（34）＆vbCrLf＆“1”＆vbCrLf＆“2”＆vbCrLf＆“3”，strName，，，，，False 
 
我= 1
直到FSO.FileExists（strFile）或者i> 6
    睡眠我* 250
     Application.StatusBar =“testingSQLcaching文件夹”＆String（i Mod 4，“。”）
循环 

如果不是FSO.FileExists（strFile）那么
     TestSQLFolder = False
其他 

     Application.StatusBar =“testingXL SQLcaching函数...” 


     “MS-Access ACE OLEDB提供程序”
    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）＆“;” 


   使用新的ADODB.Recordset
        打开“SELECT COUNT（[TestSQL]）AS T1 FROM [”＆strName＆“]”，strConn，adOpenStatic，，adCmdText
        我= 0
        我= .Fields（0）.Value
        如果我= 0那么
             i = Len（.Fields（0）.Name）
        万一
         。关
   结束 

    如果我= 0那么
         TestSQLFolder = False
    其他
         TestSQLFolder = True
    万一 

     FSO.DeleteFile strFile，True 


万一 

 Application.StatusBar = False 

结束function 


公共属性获取FSO（）作为Scripting.FileSystemObject'
 '返回一个文件系统对象
在错误恢复下一步 

如果m_objFSO没有那么
     Set m_objFSO = CreateObject（“Scripting.FileSystemObject”）'New Scripting.FileSystemObject
万一 

如果m_objFSO没有那么
     Shell“Regsvr32.exe / s scrrun.dll”，vbHide
    设置m_objFSO = CreateObject（“Scripting.FileSystemObject”）
万一 

设置FSO = m_objFSO 

最终财产 


 Public Sub SaveTable（可选TableName As String =“ ”） 

  '将一个Table对象导出到本地SQL文件夹作为一个csv文件 
  '如果没有指定名称，则所有表都是asynchronous导出的 

  '这一步对于在表上运行SQL是非常重要的 

  昏暗的周六Excel.Worksheet 
  Dim oList As Excel.ListObject 
  昏暗的sFile作为string 
  昏暗的bAsync作为布尔值 

  如果TableName =“ ”那么
     bAsync = True
其他
     bAsync = False
万一 

在ThisWorkbook.Worksheets每个工作周
    对于wks.ListObjects中的每个oList
        如果oList.Name像TableName那么
             sFile = oList.Name
             ArrayToCSV oList.Range.Value2，sFile，，，，，，，bAsync
             'Debug.Print'[“＆sFile＆”.csv]“
        万一
    下一个oList
下一个星期 

的setSchema 

结束小组 


 Public Sub RemoveTable（可选TableName As String =“*”）
在错误恢复下一步 

清除用户本地临时文件夹中的临时“表”文件： 

昏暗的周六Excel.Worksheet
 Dim oList As Excel.ListObject
昏暗的sFile作为string
昏暗sFolder作为string 

 sFolder = TempSQLFolder 

在ThisWorkbook.Worksheets每个工作周
    对于wks.ListObjects中的每个oList 


        如果oList.Name像TableName那么
             sFile = oList.Name＆“.csv”
            如果Len（Dir（sFile））> 0那么
                 Shell“CMD / c DEL”＆Chr（34）＆sFolder＆sFile＆Chr（34），vbHide'asynchronous删除
            万一
        万一 


    下一个oList
下一个星期 

结束小组

分享和享受：这是一个可怕的黑客攻击，但它给你一个稳定的SQL平台。

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

一些说明： 

 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

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

为了将数据从数据库中取出并存入Excel，请执行以下步骤。

  1. logging一个macros

  2. 导入外部数据，select一个新的源，selectDSN ODBC作为源的types。

  3. 现在selectExcel文件作为ODBC源的types。

  4. select您要查询的Excel工作表。

  5. 每个table需要在一个已命名的范围内，让选项select a table ，Excel将不允许我们插入一个查询。

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

  7. 停止录制和编辑录制的macros以满足您的需求。

它看起来像源和目标是odbc查询。 您需要从这些查询中parsing表名，并用正确的表名replace查询中的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 ...

和上面的代码应该工作。 parsingSQL语句太糟糕了，所以不要指望这很容易。 一旦你认为你有所有的可能性，另一个会popup。

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

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

  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
Interesting Posts

pandas数据框从excel命名的范围

SQL脚本根据列值自动增加

按行和列分割文本

Excel VBA：打印表单代码不起作用

Excelfunction？ 哪一个使用

使用VBA将XML数据导入到excel中，selectnodes不起作用（不返回任何内容）

VBA将单元格值设置为包含“不工作”的文本

使用VBA，范围内每个单元格的Excel自定义超链接

通过C＃.net在Excel中获取命名区域的范围

Excelmacros仅合并文件夹中多个工作簿的每个第一个工作表中的几个单元格