通过vba代码将数据从Access解析到Excel，以便根据字段内容拆分到工作表上

Sub ExportDataFromAccessToExcel()
    Dim conn As Object
    Dim rs As Object
    Dim strSQL As String
    Dim i As Integer
    Dim fld As Object
    Dim ws As Worksheet
    
    ' 创建连接对象
    Set conn = CreateObject("ADODB.Connection")
    
    ' 设置连接字符串，指定Access数据库的路径和版本
    conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Path\To\Your\Database.accdb;"
    
    ' 打开连接
    conn.Open
    
    ' 创建记录集对象
    Set rs = CreateObject("ADODB.Recordset")
    
    ' 构造SQL查询语句
    strSQL = "SELECT * FROM YourTableName"
    
    ' 执行查询
    rs.Open strSQL, conn
    
    ' 创建新的工作表
    Set ws = ThisWorkbook.Sheets.Add
    
    ' 将字段名写入第一行
    i = 1
    For Each fld In rs.Fields
        ws.Cells(1, i).Value = fld.Name
        i = i + 1
    Next fld
    
    ' 将查询结果写入工作表
    ws.Range("A2").CopyFromRecordset rs
    
    ' 关闭记录集和连接
    rs.Close
    conn.Close
    
    ' 释放对象
    Set rs = Nothing
    Set conn = Nothing
    
    ' 根据字段内容拆分到工作表上
    ' 这里需要根据具体的需求进行拆分操作，可以使用VBA的各种功能和方法来实现
    
    ' 示例：根据某个字段的值创建新的工作表，并将对应的数据复制到新的工作表上
    Dim uniqueValues As Collection
    Dim value As Variant
    
    ' 创建一个集合对象，用于存储唯一的字段值
    Set uniqueValues = New Collection
    
    ' 遍历某个字段的值，将唯一的值添加到集合中
    For i = 2 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        value = ws.Cells(i, 1).Value
        On Error Resume Next
        uniqueValues.Add value, CStr(value)
        On Error GoTo 0
    Next i
    
    ' 根据唯一的字段值创建新的工作表，并将对应的数据复制到新的工作表上
    For Each value In uniqueValues
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = CStr(value)
        i = 1
        For Each fld In rs.Fields
            ws.Cells(1, i).Value = fld.Name
            i = i + 1
        Next fld
        i = 2
        rs.MoveFirst
        Do Until rs.EOF
            If rs.Fields(1).Value = value Then
                ws.Cells(i, 1).Resize(1, rs.Fields.Count).Value = rs.Fields.Value
                i = i + 1
            End If
            rs.MoveNext
        Loop
    Next value
End Sub