在VBA中使用ADO分割工作表

有时候，我们有类似下面的工作表：

我们需要将与各部门相关的内容分别发送到各部门，让各部门对本部门相关的事项进行核对，这样，就需要将这个表按部门拆分成几个表。当然，先按部门排序再分别建表复制相关内容能够实现表格的拆分，但是，当数据记录以及部门数量较多时，这样做效率不高，我们可以考虑用VBA来提高效率，而ADO特别适合拆分这种表格（没有合并单元格，标题只有一行）。
要在VBA中使用ADO，需要先引用外部ADO库，我们通过VBE的工具菜单中的引用命令，引入最新版的ADO库Microsoft ActiveX Data Objects 6.1 Library，假定原始工作表的名称为test，下面的宏可以在test后面插入a、b、c三个工作表，每个表中包含两条本部门的记录：

Sub ADO分割工作表()
    Dim cnn As Object, rst As Recordset, Depts(), dept As Variant, Titles()
    Dim strPath$, str_cnn$, SheetName$, fcount%, i%
    '创建数据源连接对象
    Set cnn = CreateObject("adodb.connection")
    '创建查询结果记录集对象
    Set rst = CreateObject("adodb.Recordset")
    '数据源工作簿的完整路径
    strPath = ThisWorkbook.FullName
    '根据系统中Excel的版本构造数据源连接字符串。连接字符串出错有时候会引起没有可用的ISAM错误。下面各种写法都不会出现ISAM错误。注意引号与分号的位置。
    If Application.Version < 12 Then
        'str_cnn = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & strPath
        str_cnn = "Provider=Microsoft.jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & _
            strPath & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=2;"""
    Else
        'str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & strPath
        'str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Persist Security Info=False;Data Source=" & _
           'strPath & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=2"""
        str_cnn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Extended Properties='Excel 12.0;HDR=yes;IMEX=2'" & _
            ";data source=" & strPath
    End If
    SheetName = "test"
    '打开到数据源的连接
    cnn.Open str_cnn
    '取得标题行数组，实际工作中可以直接赋值。这里演示ADO查询结果集列名的获取，提高代码的通用性
    Sql = "SELECT TOP 1 * FROM [" & SheetName & "$]"
    Set rst = cnn.Execute(Sql)
    fcount = rst.fields.Count
    ReDim Titles(1 To fcount)
    For i = 0 To fcount - 1
        Titles(i + 1) = rst.fields(i).Name
    Next
    rst.Close
    '取得所有部门名称的查询语句，DISTINCT关键字对重复结果只保留一个
    Sql = "SELECT DISTINCT 部门 FROM [" & SheetName & "$]"
    '查询数据源，获得结果集。这种形式的查询访问rst.RecordCount的值总是为无意义的-1。
    Set rst = cnn.Execute(Sql)
    '将查询结果保存到数组中
    Depts = rst.GetRows()
    '关闭结果集，以待下次使用
    rst.Close
    '以部门名称为关键字，循环查询出各部门的数据，分别创建各部门工作表并予保存
    For Each dept In Depts
        '取得各部门数据的查询语句
        Sql = "SELECT * FROM [" & SheetName & "$] WHERE 部门='" & dept & "'"
        '查询数据源，获得结果集。这种形式的查询访问rst.RecordCount的值为查询结果数量。
        rst.Open Sql, cnn, 1, 3
        
        '在活动工作表后添加工作表，默认在活动工作表前插入
        ThisWorkbook.Sheets.Add after:=ActiveSheet
        With ActiveSheet
            '修改工作表名称为部门名称
            .Name = dept
            '根据查询结果数量和列数在工作表中构建出数据保存区域
            '.Range("A2").Resize(rst.RecordCount, rst.Fields.Count).CopyFromRecordset rst
            '不重构建数据保存区直接从结果集复制也可以
            .Range("A2").CopyFromRecordset rst
            '表格标题写入第一行
            .Range("A1").Resize(1, rst.fields.Count).Value = Titles
        End With
        rst.Close
    Next
    
    Set rst = Nothing
    cnn.Close
    Set cnn = Nothing    
End Sub

运行结果示意图如下：


在VBA中用ADO连接数据源，最容易踩坑的是拼接连接字符串。下面是常用数据源连接字符串：

'CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName    '//连接Excel2007
'CN.Open "Provider=Microsoft.JET.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes';data source=" & ThisWorkbook.FullName      '//OFFICE2003
'CN.Open "provider=Microsoft.JET.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\Info.mdb"
'CN.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & ThisWorkbook.Path & "\DB.mdb;Jet OLEDB:Database Password=52330067"                                                                 '//连接Access
'CN.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\数据库名.accdb;Jet OLEDB:Database Password=52330067"                                               '//连接Access2007-2010
'CN.Open "Provider=SQLOLEDB;Server=192.168.0.2;Database=元器件信息查询;Uid=sa;Pwd=1001;"                                    '//SQLServer 局域网内链接
'CN.Open "provider = OraOLEDB.oracle; Data Source = suntime; User ID =用户名; Password =密码;"                                     '//Oracle
'CN.Open "Provider=SQLOLEDB;User ID=sa;Password =1001;Data Source=FANGWEI\SQL2005数据"                                       '//SQLServer 本地链接
'CN.Open "Provider=SQLOLEDB.1;Data Source=FANGWEI;Initial Catalog=CPECC_Temp;Uid=SA;PWD=1002;Persist Security Info=false"       '//SQLServer 2008本地链接
'Data Source=服务器名称
'Initial Catalog=数据库名称
'Uid=SA 用户名
'PWD=1002 '/密码