将Access表导出到Excel，但将列中的不同值拆分为不同的工作表

Sub ExportToExcel()
    Dim rs As DAO.Recordset
    Dim ws As Excel.Worksheet
    Dim wb As Excel.Workbook
    Dim columnName As String
    Dim uniqueValues As Collection
    Dim value As Variant
    
    Set rs = CurrentDb.OpenRecordset("SELECT * FROM YourTableName")
    Set uniqueValues = New Collection
    
    ' 获取列名
    columnName = "YourColumnName"
    
    ' 收集唯一值
    Do Until rs.EOF
        On Error Resume Next
        uniqueValues.Add rs.Fields(columnName).Value, CStr(rs.Fields(columnName).Value)
        On Error GoTo 0
        rs.MoveNext
    Loop
    
    ' 创建新的Excel工作簿
    Set wb = Excel.Application.Workbooks.Add
    Set ws = wb.Sheets(1)
    
    ' 在每个工作表中导出数据
    For Each value In uniqueValues
        rs.MoveFirst
        ws.Name = value
        
        ' 导出数据到当前工作表
        ws.Range("A1").CopyFromRecordset rs
        
        ' 创建新的工作表
        Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    Next value
    
    ' 删除最后一个空白工作表
    Application.DisplayAlerts = False
    wb.Sheets(wb.Sheets.Count).Delete
    Application.DisplayAlerts = True
    
    ' 保存Excel文件
    wb.SaveAs "YourFilePath\YourFileName.xlsx"
    
    ' 关闭Excel对象
    wb.Close
    Set wb = Nothing
    
    ' 清理资源
    rs.Close
    Set rs = Nothing
    Set uniqueValues = Nothing
End Sub