更新一下之前写的Excel的数据库类,将其改成函数的形式,调用更简单(省却了生成类实例的步骤)。现在这个代码在工作中用了一年多,已经比较健壮。若有问题,请留言指出或与我联系。
这些代码有如下优势:
- 无需任何配置。在 VBA 中新建模块,并把代码复制转帖过去即可使用。
- 有以下函数:执行数据库语句、查询数据库、结果复制到单元格(Excel 中最常用)、将 Excel 表格上传到数据库。基本覆盖 Excel 中对数据库的常用操作。
- 会在立即窗口显示数据库错误信息,方便查错。
- 在数据库连接字符串字典中配好数据库连接信息后,数据库访问时可直接使用配好的链接字符串。
具体的函数用法已经写在下面代码注释里。简单描述一下:
dqQueryToArray(sql, connection_string)
查询数据库,返回一个二维数组dbQueryOne(sql, connection_string)
查询数据库,返回单个变量。dbQueryToCell(sql, range, connection_string, withHeader)
查询数据库后,将结果显示在 range 开始的区域中; withHeader 控制是否显示列名。dbExec(sql, necction_string)
执行数据库语句;无返回值dbInsertRange(table, range, connection_string, is_empty)
将本 Excel 文件的 range 区域里的数据插入到数据库的表 table。其中is_empty
控制在上传数据前是否清空 table 的原数据。
其它就看一下代码吧:
' EXCEL的ADO数据库操作函数库 ' 这些代码应该放在Excel的VBA模块中,类模块的名字为database,并以以下形式引用: ' ' res = dbQueryToArry(sql, connection_string) ' ' 返回sql的查询结果,结果为一个二维数组 ' res = dbQueryOne(sql, connection_string) ' ' 返回sql的查询结果,但只返回第一个数据(相当于数据库查询结果的左上角那个数据) ' dbQueryToCell sql, save_to_range, connection_string, withHeader ' ' 将sql的查询结果直接写入到以save_to_range开头的单元格区域中 ' ' withHeader控制是否复制表头,默认为true(复制表头) ' ' 其中参数sql为数据库查询语句,connection_string为数据库连接字符串。 ' ' 比如要连接SQL数据库,并已经设置ODBC,连接字符串为: ' "Provider=MSDASQL;DSN=odbc_name;UID=username;PWD=password;database=database_name;" ' 如果未设置ODBC,连接字符串为: ' "driver={SQL Server};server=service_name_or_ip;uid=username;pwd=password;database=database_name;" ' 其中最后面的database变量可省略。对于SQL Server,推荐使用后一种方法。 ' ' 如果数据来源为Excel文件,connection_string参数可省略 ' ' 其它功能:内置数据库的连接字符串、查询存储过程 ' ' ' url: /it/excel-vba-database-functions.html Private sqlDict As Object ' 缓存数据 Private cnn As Object, rst As Object, lastConn As String Private Sub dbInitialize() If Not sqlDict Is Nothing Then Exit Sub Set sqlDict = CreateObject("scripting.Dictionary") lastConn = "" ' 在这里可以缓存一些常用的数据库信息,这样在查询数据库时可以直接调用 ' 比如dbQueryToArry(sql, "this") With sqlDict .Add "SQL服务器", _ "Provider=MSDASQL;DSN=odbc_name;UID=username;PWD=password;database=database_name;" .Add "SQL服务器(无需配置ODBC)", _ "driver={SQL Server};server=ip;uid=username;pwd=password;database=database_name;" .Add "this", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _ ";Extended Properties=Excel " & Application.Version & ";" End With End Sub ' 查询数据库,返回RecordSet对象 ' sql: 数据库查询语句 ' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等, ' 利用内设的数据库连接信息 Public Function dbQuery(sql As String, _ Optional ByVal sqlConnectString As String = "this") As Object ' ADODB.Recordset dbConnectSQL sqlConnectString On Error GoTo errorhander rst.Open sql, cnn Set dbQuery = rst errorhander: dbDisplayError sql End Function ' 查询数据库,返回一个数组 ' sql: 数据库查询语句 ' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等, ' 利用内设的数据库连接信息 Public Function dbQueryToArray(sql As String, _ Optional ByVal sqlConnectString As String = "this") dbConnectSQL sqlConnectString On Error GoTo errorhander rst.Open sql, cnn dbQueryToArray = rst.GetRows(10000000) errorhander: DisplayError sql End Function ' 查询数据库,返回单个数值 ' sql: 数据库查询语句 ' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等, ' 利用内设的数据库连接信息 Public Function dbQueryOne(sql As String, _ Optional ByVal sqlConnectString As String = "this") dbConnectSQL sqlConnectString On Error GoTo errorhander rst.Open sql, cnn dbQueryOne = rst.Fields.Item(0).value errorhander: dbDisplayError sql End Function ' 查询数据库,返回单个数值 ' sql: 数据库查询语句 ' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等, ' 利用内设的数据库连接信息 Public Function dbQueryToCell(sql$, Optional rng As Excel.Range, _ Optional ByVal sqlConnectString$ = "this", _ Optional withHeader As Boolean = True) On Error GoTo error_handler dbConnectSQL sqlConnectString rst.Open sql, cnn Set rng = rng.Cells(1, 1) If withHeader = True Then Dim i As Long For i = 0 To rst.Fields.Count - 1 rng.Offset(0, i).value = rst.Fields(i).Name Next rng.Offset(1, 0).CopyFromRecordset rst Else rng.CopyFromRecordset rst End If error_handler: dbDisplayError sql End Function ' 执行任意数据库语句,无返回结果。如需返回结果,请使用Query、QueryOne、QueryToCell等函数 ' sql: 数据库查询语句 ' sqlConnectString: 数据库连接信息,或者直接指定数据库,比如"Wind"、"JYDB"等,利用内设的数据库连接信息 Sub dbExec(ByVal sql As String, _ Optional ByVal sqlConnectString As String = "this") dbConnectSQL sqlConnectString On Error GoTo errorhander cnn.Execute sql errorhander: dbDisplayError sql End Sub ' 这个函数用来上传一个Excel区域到数据库,数据表必须事先建好,并且包括Excel区域的第一行 ' Database.InsertRange(table, rng, sqlConnectString, isEmpty) ' table:Excel数据将上传到这个表内 ' rng: 将被上传的Excel区域 ' sqlConnectString: 数据库连接字符串 ' isEmpty: 是否清空原有表格数据 Public Function dbInsertRange(table$, rng As Excel.Range, Optional ByVal sqlConnectString$ = "this", _ Optional isEmpty As Boolean = False) dbConnectSQL sqlConnectString On Error Resume Next If isEmpty Then dbExec "delete from " & table, sqlConnectString$ Dim r As Long, sqlHead$, i As Long ' 首选根据isEmpty选项,删除原表内所有数据 For i = 1 To rng.Columns.Count sqlHead = sqlHead & ",[" & rng.Cells(1, i) & "]" Next i ' 其次,依次拆入每行 ' 目前每一行都需运行一个SQL语句,效率较低,如果数据量较大,可能会引起Excel死机 sqlHead = "insert into " & table & " (" & mid(sqlHead, 2, 10000000) & ") values " For r = 2 To rng.rows.Count Dim sql$ sql = "" For i = 1 To rng.Columns.Count Dim v v = rng.Cells(r, i).value() If IsError(v) Then v = "" If IsDate(v) Then sql = sql & ",'" & Format(v, "yyyy-mm-dd") & "'" ElseIf v <> "" And IsNumeric(v) Then sql = sql & "," & v Else sql = sql & ",'" & v & "'" End If Next i dbExec sqlHead & " (" & mid(sql, 2, 1000000) & ")", sqlConnectString$ Next r End Function ' 查询存储过程,返回的是ADODB.RecordSet对象 Public Function dbQueryStoredProc(procName$, para, _ Optional ByVal sqlConnectString As String = "this", _ Optional returnPara As Boolean = True) As Object 'ADODB.Recordset On Error GoTo errorhander dbConnectSQL sqlConnectString With com .ActiveConnection = cnn .CommandType = adCmdStoredProc .CommandText = procName ' 获取存储过程的参数定义 .Parameters.Refresh ' 如果存在输出参数,则删除它,默认第一个为输出参数 On Error Resume Next If returnPara Then .Parameters.Delete 0 ' 设置输入参数的值 If IsArray(para) Then Dim i For i = 0 To UBound(para) .Parameters.Item(i).value = para(i) Next i End If ' 改变输入参数大小 Dim tmpp For Each tmpp In .Parameters tmpp.Size = 255 Next tmpp ' 获取参数返回值 Set dbQueryStoredProc = .Execute() End With errorhander: DisplayError sql End Function Private Sub dbClose() ' 当类被注销时,断开数据库连接 On Error Resume Next If cnn.State <> 0 Then cnn.Close End Sub ' 连接数据库 ' 此处首先检查cnn是否已经连接到想要连接的数据库,如果已经连接,将不产生任何操作 ' 本Database对象在对象存续过程中,不会主动断开; ' 只有在对象注销之时,才断开数据库,如需断开数据库连接,请set db = nothing Private Function dbConnectSQL(ByVal sqlConnectString$) As String On Error Resume Next Call dbInitialize If sqlDict.Exists(LCase(sqlConnectString)) Then sqlConnectString = sqlDict.Item(LCase(sqlConnectString)) End If If rst Is Nothing Then Set rst = CreateObject("ADODB.Recordset") If cnn Is Nothing Then Set cnn = CreateObject("ADODB.Connection") If cnn.State <> 1 Or lastCnn <> sqlConnectString Then cnn.Close Set cnn = Nothing Set cnn = CreateObject("ADODB.Connection") cnn.Open sqlConnectString lastConn = sqlConnectString End If dbConnectSQL = sqlConnectString End Function ' 显示查询数据库过程中出现的错误信息,信息被显示在立即窗口。 Private Sub dbDisplayError(sql$) Dim e If cnn.Errors.Count > 0 Then Debug.Print cnn.Errors.Count & " errors found when exec """ & sql & """" For Each e In cnn.Errors Debug.Print "Error info: " & e.description & " Source: " & e.Source Next e End If End Sub
原文:https://zhiqiang.org/coding/excel-vba-database-functions.html