Excel自连接数据类？

Option Explicit

'这个函数不好用，数据连接打开后不能关闭，否则记录集无法操作
Public Function GetRecordsetForSQL(ByVal Sql As String) As ADODB.Recordset
    
    Dim Cnn As New ADODB.Connection     '定义数据库类变量
    Dim Rst As New ADODB.Recordset

    With Cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties").value = "Excel 8.0"
        .Properties("data Source").value = ThisWorkbook.FullName
        
        .Open
        
        Rst.Open Sql, Cnn, 3, 4
        
        With Rst
           
           Set GetRecordsetForSQL = Rst
        
        End With
        
    End With
End Function

Public Function GetDwmcArray() As String()

    Dim dwmc() As String
    dwmc = Sheets("xtdw").Range("a2:a6")
    MsgBox dwmc(1), vbInformation, "提示"
    
End Function


'ADODB方式连接SqlServer数据库
'数据库连接方法:

'连接数据库，返回数据连接
'数据源为本工作簿
Public Function GetConnExcel1() As Connection
    
    Dim conn As New ADODB.Connection     '定义数据库类变量
    Set conn = New ADODB.Connection
    
    Dim connstr As String
    connstr = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    
    conn.Open connstr
    
    If conn Is Nothing Then
        Set GetConnExcel1 = Nothing
    Else
        Set GetConnExcel1 = conn
    End If
    
End Function

'ADODB方式连接SqlServer数据库
'数据库连接方法:

'连接数据库，返回数据连接
'数据源为本工作簿
Public Function GetConnExcel() As Connection
    
    Dim conn As New ADODB.Connection     '定义数据库类变量
    Set conn = New ADODB.Connection
    
    With conn
        
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        '.IMEX = 1
        .Properties("Extended Properties").value = "Excel 8.0"
        .Properties("data Source").value = ThisWorkbook.FullName
        .Open
        
    End With
    
    If conn Is Nothing Then
        Set GetConnExcel = Nothing
    Else
        Set GetConnExcel = conn
    End If
    
End Function



'关闭数据库连接方法代码如下
'此函数多余
Public Function closeConnection(ByVal conn As Connection)

    If Not conn Is Nothing Then
    
        conn.Close
    
    End If

End Function
'其中，参数 conn ：要关闭的连接。

'执行查询语句的方法代码如下：（返回rs数据集）
Public Function ExecuteQuery(ByVal conn As Connection, querySql As String) As Recordset
    
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    If Not conn Is Nothing Then
    
        rs.Open querySql, conn, 3, 3
        
    End If
        
    Set ExecuteQuery = rs
    
End Function

'''expresswhere---条件表达式，不带where
'''示例－－－“dwxh = 2”
Public Function GetQuerySQLString(ByVal sheetName As String, _
    ByVal fristcolumn As String, _
    ByVal endcolumn As String, _
    ByVal queryfields As String, _
    ByVal expresswhere As String) As String
    
    Dim Sql As String
    
    Sql = "select " & queryfields & " from [" & sheetName & "$" & fristcolumn & ":" & endcolumn & "]"
    
    If expresswhere <> "" Then
        Sql = Sql & " where " & expresswhere
    End If
        
    GetQuerySQLString = Sql

End Function
'其中，参数 conn ：数据库连接、querySql ：查询语句。返回值为查询结果集。


''添加新记录
'Public Function AddNewRecord(ByVal conn As ADODB.Connection, ByVal sql As String)
'
'End Function

Sub ADO法()
    Dim Cnn As Object, Sql$, f$
    Set Cnn = CreateObject("ADODB.Connection")
    Cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
    f = ThisWorkbook.path & "\模拟效果\" & ActiveSheet.name & ".xls"
    If Dir(f) <> "" Then Kill f
    Sql = "select * into [" & f & "]." & ActiveSheet.name & " from [" & ActiveSheet.name & "$a:f]"
    Cnn.Execute Sql
    Cnn.Close
    Set Cnn = Nothing
    MsgBox "ok"
End Sub