在EXCEL中操作ACCESS库

zez

以后改为发代码,不再传附件,目前及以后所发代码需要的MDB文件见27楼,直到另传附件

Public Sub 导入部份字段数据1()
    Dim myData As String, myTable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    myData = ThisWorkbook.Path & "\职工管理.mdb"
    myTable = "职工基本信息"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open myData
    End With
    SQL = "select 姓名,性别,所属部门,职务,职称,年龄,进本单位时间 from " _
        & myTable & " order by 职工编号"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 导入部份字段数据2()
    Dim myData As String, myTable As String, SQL As String
    Dim myDb As DAO.Database
    Dim myRs As DAO.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    myData = ThisWorkbook.Path & "\职工管理.mdb"
    myTable = "职工基本信息"
    Set myDb = OpenDatabase(myData)
    SQL = "select 姓名,性别,所属部门,职务,职称,年龄,进本单位时间 from " _
        & myTable & " order by 职工编号"
    Set myRs = myDb.OpenRecordset(SQL)
    For i = 1 To myRs.Fields.Count
        Cells(1, i) = myRs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, myRs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset myRs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    myRs.Close
    myDb.Close
    Set myRs = Nothing
    Set myDb = Nothing
End Sub

zez

Public Sub 查询全部字段前面若干条记录()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    SQL = "select top 5 * from " & mytable _
        & " where 年龄>40 order by 年龄 DESC"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 查询部份字段前面若干条记录()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    mydata = ThisWorkbook.Path & "\职工管理.mdb"
    mytable = "职工基本信息"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    SQL = "select top 5 姓名,性别,所属部门,职务,职称,年龄,进本单位时间" _
        & " from " & mytable _
        & " where 年龄>40 order by 年龄 DESC"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 查询不重复字段的内容()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    '清除工作表的全部数据
    ActiveSheet.Cells.Clear
    '输入标题
    With Range("A1:C1")
        .Value = Array("部门", "职称类别", "职务类别")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    '指定数据库和数据表
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    '建立与数据库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    '查询数据表中不重复的部门名称，并复制数据
    SQL = "select distinct 所属部门 from " & mytable
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    Range("A2").CopyFromRecordset rs
    '查询数据表中不重复的职称类别名称，并复制数据
    SQL = "select distinct 职称 from " & mytable
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    Range("B2").CopyFromRecordset rs
    '查询数据表中不重复的职务名称，并复制数据
    SQL = "select distinct 职务 from " & mytable
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    Range("C2").CopyFromRecordset rs
    '设置工作表格式
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    '关闭记录集及数据库连接,并释放变量
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub
Public Sub 利用Like运算符进行模糊查询()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    '清除工作表的全部数据
    ActiveSheet.Cells.Clear
    '指定数据库和数据表
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    '建立与数据库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    '查询数据表
    SQL = "select * from " & mytable & " where 姓名 like '李%'"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    '复制字段名
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    '设置字段名字体为加粗并居中对齐
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    '复制全部数据
    Range("A2").CopyFromRecordset rs
    '设置工作表格式
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    '关闭记录集及数据库连接,并释放变量
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub
Public Sub 查询某一区间的记录()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    '清除工作表的全部数据
    ActiveSheet.Cells.Clear
    '指定数据库和数据表
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    '建立与数据库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    '查询数据表
    SQL = "select * from " & mytable _
        & " where 年龄 between 30 and 40 order by 年龄 DESC"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    '复制字段名
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    '设置字段名字体为加粗并居中对齐
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    '复制全部数据
    Range("A2").CopyFromRecordset rs
    '设置工作表格式
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    '关闭记录集及数据库连接,并释放变量
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub
Public Sub 查询存在于某集合里面的记录()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    mydata = ThisWorkbook.Path & "\职工管理.mdb"
    mytable = "职工基本信息"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    SQL = "select * from " & mytable _
        & " where 年龄> 40 and 职称 in('工程师','经济师') order by 年龄 DESC"
    Set rs = cnn.Execute(SQL)
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

zez

Public Sub 将查询结果进行排序()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    mydata = ThisWorkbook.Path & "\职工管理.mdb"
    mytable = "职工基本信息"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    SQL = "select * from " & mytable _
        & " order by 年龄 DESC, 工龄 DESC, 本单位工龄 DESC"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 复杂条件查询()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    ActiveSheet.Cells.Clear
    mydata = ThisWorkbook.Path & "\职工管理.mdb"
    mytable = "职工基本信息"
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    SQL = "select * from " & mytable _
        & " where 职称='工程师' and (年龄 between 30 and 40)" _
        & " and 文化程度 in('硕士','博士') order by 职工编号"
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    '复制字段名
    For i = 1 To rs.Fields.Count
        Cells(1, i) = rs.Fields(i - 1).Name
    Next i
    With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("A2").CopyFromRecordset rs
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 查询最大值和最小值()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer
    '清除工作表的全部数据
    ActiveSheet.Cells.Clear
    '指定数据库和数据表
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    '建立与数据库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    '查询数据表
    SQL = "select max(年龄) as Age1,min(年龄) as Age2," _
        & "max(工龄) as Workage1,min(工龄) as Workage2," _
        & "max(本单位工龄) as Dage1,min(本单位工龄) as Dage2 " _
        & "from " & mytable
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    '也可以使用下面的语句
'    Set rs = cnn.Execute(SQL)
    '复制数据
    Range("A1:F1") = Array("最大年龄", "最小年龄", "最大工龄", _
        "最小工龄", "最大本单位工龄", "最小本单位工龄")
    Range("A2:F2") = Array(rs!Age1, rs!Age2, _
        rs!Workage1, rs!Workage2, rs!Dage1, rs!Dage2)
    '设置工作表格式
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    '关闭记录集及数据库连接,并释放变量
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

Public Sub 查询合计值和平均值()
    Dim mydata As String, mytable As String, SQL As String
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim i As Integer, DeptTotal As Integer
    '清除工作表的全部数据
    ActiveSheet.Cells.Clear
    '指定数据库和数据表
    mydata = ThisWorkbook.Path & "\职工管理.mdb"    '指定数据库
    mytable = "职工基本信息"      '指定数据表
    '建立与数据库的连接
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open mydata
    End With
    '查询不重复的部门名称
    SQL = "select distinct 所属部门 from " & mytable
    Set rs = New ADODB.Recordset
    rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
    DeptTotal = rs.RecordCount
    ReDim myDept(1 To DeptTotal)
    For i = 1 To DeptTotal
        myDept(i) = rs.Fields("所属部门")
        rs.MoveNext
    Next i
    '开始查询计算各部门的平均年龄
    Range("A1:B1") = Array("部门", "平均年龄")
    For i = 1 To DeptTotal
        Cells(i + 1, 1) = myDept(i)
        SQL = "select avg(年龄) as myAvg from " & mytable _
            & " where 所属部门='" & myDept(i) & "'"
        Set rs = cnn.Execute(SQL)
        Cells(i + 1, 2) = Round(rs!myAvg, 2)
    Next i
    '开始查询计算本单位全部职工的平均年龄
    Range("C1:E1") = Array("本单位全部职工", "本单位男职工", "本单位女职工")
    SQL = "select avg(年龄) as myAvg from " & mytable
    Set rs = cnn.Execute(SQL)
    Cells(2, 3) = Round(rs!myAvg, 2)
    '开始查询计算本单位男职工的平均年龄
    SQL = "select avg(年龄) as myAvg from " & mytable & " where 性别='男'"
    Set rs = cnn.Execute(SQL)
    Cells(2, 4) = Round(rs!myAvg, 2)
    '开始查询计算本单位女职工的平均年龄
    SQL = "select avg(年龄) as myAvg from " & mytable & " where 性别='女'"
    Set rs = cnn.Execute(SQL)
    Cells(2, 5) = Round(rs!myAvg, 2)
    '设置工作表格式
    ActiveSheet.Cells.Font.Size = 10
    ActiveSheet.Columns.AutoFit
    '关闭记录集及数据库连接,并释放变量
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

kinglw

这个对我来说还太难，现在还要学习初级的呢，不过还是非常感谢LZ的无私奉献精神，等学的小有所成的时候再来拜师

幸福的学习

多谢!

xylf

利用工作表数据创建数据表方法

feilong5xian

送楼主鲜花一朵！

[em22]

wuhanp005

本人菜鸟一个,多谢多谢.

zez

qQgJn7NR.rar (1.82 KB, 下载次数: 3292)

2008-10-14 09:44 上传

点击文件名下载附件
在EXCEL中操作ACCESS库

zez

a26LE63z.rar (22.41 KB, 下载次数: 3792)

2008-10-14 09:50 上传

点击文件名下载附件
在EXCEL中操作ACCESS库