ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 Office知识技巧免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 825|回复: 9

[原创] 用类做自定义SQL读取函数及数组转置函数

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-11 17:27 | 显示全部楼层 |阅读模式
本帖最后由 microyip 于 2020-1-17 08:03 编辑

今天看了一个帖子http://club.excelhome.net/thread-1517776-1-1.html自己封装的VBA 连接数据库的函数
首先,我对作者的做适合自己使用的函数表示衷心赞赏。
接着,其实这个对一些对SQL应用有需求的人来说,也无疑是一个省事的操作。于是,把自己做的一个类修改成类似教程的样式,分享出来给大家使用。
SQL方式读取数据、数组转置的类(by.micro).rar (68.18 KB, 下载次数: 183)

评分

参与人数 9鲜花 +20 收起 理由
七夕、 + 3 优秀作品
zhangmi + 2 太强大了
917067811 + 2 优秀作品
FOB_FN_L + 2 太强大了
shandongdxl + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 17:27 | 显示全部楼层
本帖最后由 microyip 于 2020-1-17 08:00 编辑

建立类模块ClassSQL
  1. Private oConn As Object, oRS As Object, dicConnString As Object

  2. Private Sub Class_Initialize() '类初始化过程
  3.     Set oConn = CreateObject("Adodb.Connection") '设置ADO连接对象
  4.     Set oRS = CreateObject("Adodb.RecordSet") '设置ADO记录对象
  5.     With oRS
  6.         .CursorLocation = 3 ' (实际是adUseClient值,考虑到没有引用ActiveX Data Objects Library,无法直接引用,改用数值代替)
  7.         .CursorType = 3 ' (实际是adOpenStatic值,考虑到没有引用ActiveX Data Objects Library,无法直接引用,改用数值代替)
  8.         .LockType = 4 ' (实际是adLockBatchOptimistic值,考虑到没有引用ActiveX Data Objects Library,无法直接引用,改用数值代替)
  9.     End With
  10.    
  11.     Set dicConnString = CreateObject("Scripting.Dictionary") '建立打开ADO连接对象的语句字典
  12.     dicConnString("SQL") = "Provider=SQLOLEDB; User ID=SqlUserID;Password =SqlPassword;Data Source=SqlServerIP" 'SQL的打开ADO连接对象语句
  13.     If Val(Application.Version) < 12 Then
  14.         dicConnString("Excel") = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source=" 'Excel2003及以下的打开ADO连接对象语句
  15.         dicConnString("Access") = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" 'Access2003及以下的打开ADO连接对象语句
  16.     Else
  17.         dicConnString("Excel") = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2';Data Source=" 'Excel2007及以上的打开ADO连接对象语句
  18.         dicConnString("Access") = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" 'Access2007及以上的打开ADO连接对象语句
  19.     End If
  20. End Sub

  21. '——————数组转置——————开始
  22. Function Transpose(ByVal Data As Variant, Optional To2Dim As Boolean) As Variant
  23. '------------------------------
  24. '功能:转置二维以下的数组
  25. '参数说明:
  26. 'To2Dim,强制为二维数组
  27. '------------------------------
  28.    
  29.     Dim vNew As Variant, nNewRow As Double, nNewCol As Double
  30.     Dim nRow As Double, nCol As Double, nDim As Long
  31.     Dim nMinRow As Double, nMaxRow As Double, nMinCol As Double, nMaxCol As Double
  32.    
  33.     If Not IsArray(Data) Then '如果源数组不是数组
  34.         If To2Dim Then
  35.             ReDim vNew(1 To 1, 1 To 1)
  36.             vNew(1, 1) = Data
  37.         Else
  38.             ReDim vNew(1 To 1)
  39.             vNew(1) = Data
  40.         End If
  41.     Else
  42.         nDim = 1 '预设源数组维度为1维
  43.         On Error Resume Next
  44.         Do
  45.             vNew = UBound(Data, nDim + 1) '尝试读取源数组数据的第nDim+1维的最大上限值
  46.             If Err.Number <> 0 Then Exit Do
  47.             nDim = nDim + 1
  48.         Loop
  49.         Err.Clear
  50.         On Error GoTo 0
  51.         If nDim >= 3 Then Exit Function '源数组维数大于或等于3时
  52.         
  53.         nMinRow = LBound(Data) '源数组最少行号
  54.         nMaxRow = UBound(Data) '源数组最大行号
  55.         If nDim = 1 Then
  56.             ReDim vNew(1 To 1, 1 To nMaxRow - nMinRow + 1)
  57.             For nRow = nMinRow To nMaxRow
  58.                 nNewRow = nNewRow + 1
  59.                 If Not IsError(Data(nRow)) Then vNew(1, nNewRow) = Data(nRow)
  60.             Next
  61.         Else
  62.             nMinCol = LBound(Data, 2) '源数组最小列号
  63.             nMaxCol = UBound(Data, 2) '源数组最大列号
  64.             If nMinRow = nMaxRow And Not To2Dim Then
  65.                 ReDim vNew(1 To nMaxCol - nMinCol + 1)
  66.                 nRow = nMinRow
  67.                 For nCol = nMinCol To nMaxCol
  68.                     nNewCol = nNewCol + 1
  69.                     If Not (IsError(Data(nRow, nCol)) Or IsNull(Data(nRow, nCol))) Then vNew(nNewCol) = Data(nRow, nCol)
  70.                     'IsError的检查,目的是解决Excel读取的数值可能存在错误值
  71.                     'Isnull的检查,目的是解决Access或SQL读取的数据可能存在Null数值
  72.                 Next
  73.             Else
  74.                 ReDim vNew(1 To nMaxCol - nMinCol + 1, 1 To nMaxRow - nMinRow + 1)
  75.                 For nRow = nMinRow To nMaxRow
  76.                     nNewCol = nNewCol + 1
  77.                     nNewRow = 0
  78.                     For nCol = nMinCol To nMaxCol
  79.                         nNewRow = nNewRow + 1
  80.                         If Not (IsError(Data(nRow, nCol)) Or IsNull(Data(nRow, nCol))) Then vNew(nNewRow, nNewCol) = Data(nRow, nCol)
  81.                     Next
  82.                 Next
  83.             End If
  84.         End If
  85.     End If
  86.     Transpose = vNew
  87. End Function
  88. '——————数组转置——————结束

  89. '——————SQL获取数据——————开始
  90. Function GetDataBySQL(ByVal SQL As String, ByVal SqlType As String, ByVal FileOrServer As String, _
  91.     Optional ByVal UserID As String, Optional UserPassword As String, Optional ByVal OutputTitle As Boolean, Optional ByVal ExcelUseTitle As Boolean = True) As Variant
  92. '----------------------------------------------------------------------------------------------------
  93. '参数说明:
  94. 'SQL,SQL语句
  95. 'SqlType,SQL读取对象类型,注意大小写,包括"SQL"、"Excel"、"Access"
  96. 'FileOrServer,Excel和Access文件全路径名或者SQL服务器IP
  97. 'UserID,读取SQL服务器时的用户帐号,对于读取Excel和Access时不用填
  98. 'UserPassword,读取SQL服务器时的用户密码,对于读取Excel和Access时不用填
  99. 'OutputTitle,可选项,默认为False,输出数据是否带标题
  100. 'ExcelUseTitle,可选项,默认为True,只对Excel读取产生作用,读取Excel时是否将第一行认为是标题
  101. '----------------------------------------------------------------------------------------------------

  102.     Dim vTmp As Variant, nRow As Double, nCol As Double, vRS As Variant, sConnString As String
  103.       
  104.     If dicConnString.exists(SqlType) Then '检查是否存在打开ADO连接的语句
  105.         sConnString = dicConnString(SqlType)
  106.     Else
  107.         GetDataBySQL = "不是指定的SQL读取对象类型!请使用""SQL""、""Excel""、""Access""其中一种!"
  108.         Exit Function
  109.     End If
  110.    
  111.     If FileOrServer = "" Then
  112.         If SqlType = "SQL" Then
  113.             GetDataBySQL = "未设置SQL读取对象的SQL服务器IP!"
  114.         Else
  115.             GetDataBySQL = "未设置SQL读取对象的Excel或Access文件的全路径文件名!"
  116.         End If
  117.         Exit Function
  118.     End If
  119.    
  120.     If SqlType = "SQL" Then
  121.         If UserID = "" Then UserID = "sa"
  122.         sConnString = Replace(sConnString, "SqlUserID", UserID)
  123.         sConnString = Replace(sConnString, "SqlPassword", UserPassword)
  124.         sConnString = Replace(sConnString, "SqlServerIP", FileOrServer)
  125.     Else
  126.         If SqlType = "Excel" And Not ExcelUseTitle Then sConnString = Replace(sConnString, "YES", "NO")
  127.         sConnString = sConnString & FileOrServer
  128.     End If
  129.    
  130.     On Error Resume Next
  131.     With oConn
  132.         If oRS.State Then oRS.Close '检查ADO记录对象是否处于打开,如果打开就关闭
  133.         If .State Then .Close '检查ADO连接对象是否处于打开,如果打开就关闭
  134.         .ConnectionString = sConnString '设置ADO连接对象的连接方式
  135.         .Open '打开ADO连接对象
  136.         If Err.Number <> 0 Then
  137.             Err.Clear
  138.             If SqlType = "SQL" Then
  139.                 GetDataBySQL = "SQL服务器连接失败,请检查服务器IP、用户帐号、用户密码!"
  140.             Else
  141.                 GetDataBySQL = SqlType & "连接失败,请检查全路径文件名是否正确!"
  142.             End If
  143.             On Error GoTo 0
  144.             Exit Function
  145.         End If
  146.         If SqlType = "SQL" Then
  147.             .CommandTimeout = 720 '设置命令执行超时时间
  148.             .ConnectionTimeout = 720 '设置连接超时时间
  149.         End If
  150.         
  151.         Set oRS = .Execute(SQL) '执行SQL语句并返回到ADO记录对象
  152.         If Err.Number <> 0 Then
  153.             Err.Clear
  154.             GetDataBySQL = "SQL语句错误!"
  155.             On Error GoTo 0
  156.             Exit Function
  157.         End If
  158.         
  159.         On Error GoTo 0
  160.         If oRS.State Then  '如果执行Delete,Update之类语句,此记录处于关闭状态
  161.             If OutputTitle Then
  162.                 ReDim vTmp(1 To oRS.Fields.Count, 1 To 1) '建立标题数组
  163.                 Do While nCol < oRS.Fields.Count '
  164.                     vTmp(nCol + 1, 1) = oRS.Fields(nCol).Name '字段名
  165.                     nCol = nCol + 1
  166.                 Loop
  167.             End If
  168.         
  169.             If Not (oRS.EOF And oRS.BOF) Then
  170.                 vRS = oRS.GetRows '从ADO记录对象中获取数据数组
  171.                 If IsArray(vRS) Then
  172.                     vRS = Transpose(Data:=vRS, To2Dim:=True) '转置数据数组
  173.                     If OutputTitle Then
  174.                         ReDim Preserve vTmp(1 To UBound(vTmp), 1 To 1 + UBound(vRS)) '将标题数组扩展到数据数组的行数
  175.                         vTmp = Transpose(Data:=vTmp, To2Dim:=True) '转置带标题的空数据数组
  176.                         For nRow = 1 To UBound(vRS)
  177.                             For nCol = 1 To UBound(vRS, 2)
  178.                                 vTmp(1 + nRow, nCol) = vRS(nRow, nCol) '从数据数组向带标题的数组赋值数据
  179.                             Next
  180.                         Next
  181.                         vRS = vTmp
  182.                     End If
  183.                 End If
  184.             ElseIf OutputTitle Then
  185.                 vRS = Transpose(Data:=vTmp, To2Dim:=True) '转置标题数组
  186.             Else
  187.                 vRS = "没有符合条件数据!"
  188.             End If
  189.             GetDataBySQL = vRS
  190.             
  191.             oRS.Close
  192.         End If
  193.         If .State Then .Close
  194.     End With
  195. End Function
  196. '——————SQL获取数据——————结束
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-11 17:28 | 显示全部楼层
示例模块代码
  1. Private clsSQL As ClassSQL

  2. Sub Tr_Sample()
  3. '转置二维以下的数组示例
  4.     Dim vData As Variant, vNew As Variant
  5.    
  6.     If clsSQL Is Nothing Then Set clsSQL = New ClassSQL '如果clsSQL变量未初始化设置,进行初始化设置
  7.    
  8.     vNew = clsSQL.Transpose(Data:=vData) '对未进行设置的vData变形变量进行转置
  9.     MsgBox "成功转置未进行设置的vData变形变量成功转置!"
  10.    
  11.     vNew = clsSQL.Transpose(Data:="这是字符串") '对字符串进行转置
  12.     MsgBox "成功转置字符串并得到vNew一维数值!"
  13.    
  14.     vNew = clsSQL.Transpose(Data:=123, To2Dim:=True) '对数字进行强制转置为二维数组
  15.     MsgBox "成功强制转置数字并得到vNew二维数值!"
  16.    
  17.     ReDim vData(1 To 2) '设置vData为一维数组
  18.     vNew = clsSQL.Transpose(Data:=vData) '对一维vData数组进行转置
  19.     MsgBox "成功转置一维数组并得到vNew二维数值!"
  20.      
  21.     vData = Sheet1.[A1:C1].Value '从表中获取一列数组
  22.     vNew = clsSQL.Transpose(Data:=vData) '对vData数组进行转置
  23.     MsgBox "成功转置只有一行数据的二维数组并得到vNew一维数值!"
  24.     vNew = clsSQL.Transpose(Data:=vData, To2Dim:=True) '对vData数组进行强制转置为二维数组
  25.     MsgBox "成功强制转置只有一行数据的二维数组并得到vNew二维数值!"
  26.    
  27.     vData = Sheet1.[A1:C30].Value '从表中获取数组
  28.     vNew = clsSQL.Transpose(vData) '对vData数组进行转置
  29.     MsgBox "成功转置数组并得到vNew二维数值!"
  30. End Sub
  31.    
  32. Sub BT_Click(ByVal SqlType As String)
  33. 'SQL方式读取数据
  34.     Dim sSQL As String, vData As Variant, bOutputTitle As Boolean, wSH As Worksheet
  35.    
  36.     If clsSQL Is Nothing Then Set clsSQL = New ClassSQL '如果clsSQL变量未初始化设置,进行初始化设置
  37.    
  38.     bOutputTitle = Sheet1.ToggleButton1.Value '使用输出有标题数据
  39.     If bOutputTitle Then
  40.         Set wSH = Sheet2 '有标题的输出表
  41.     Else
  42.         Set wSH = Sheet3 '无标题的输出表
  43.     End If
  44.    
  45.     If SqlType = "SQL" Then
  46.         sSQL = "Select * From [库名].dbo.[表名]"
  47.         '注意:库名为数据库的名字,表名为数据库内的表的名字
  48.         vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:="192.168.1.231", UserID:="sa", UserPassword:="sa", OutputTitle:=bOutputTitle)
  49.     ElseIf SqlType = "Excel" Then
  50.         sSQL = "Select * From [源数据$] Where [数值]>500"
  51.         vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:=ThisWorkbook.Path & "\test.xlsx", OutputTitle:=bOutputTitle)
  52.     ElseIf SqlType = "Access" Then
  53.         sSQL = "Select * From [源数据] Where [数值]<200"
  54.         vData = clsSQL.GetDataBySQL(SQL:=sSQL, SqlType:=SqlType, FileOrServer:=ThisWorkbook.Path & "\test.accdb", OutputTitle:=bOutputTitle)
  55.     End If
  56.     If Not IsArray(vData) Then '说明SQL读取失败
  57.         MsgBox vData
  58.     Else
  59.         With wSH
  60.             .UsedRange.Offset(1 + 1 * bOutputTitle).ClearContents
  61.             .[A1].Offset(1 + 1 * bOutputTitle).Resize(UBound(vData), UBound(vData, 2)) = vData
  62.             .Select
  63.         End With
  64.     End If
  65. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-12 10:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-16 21:59 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-17 02:47 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-10-9 11:20 | 显示全部楼层
小火箭,这个肯定用的到,收藏了!

TA的精华主题

TA的得分主题

发表于 2020-10-9 21:06 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-10-21 04:52 , Processed in 0.085504 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2021 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表