常用代码归集

jsgj2023

Sub 提取指定班级性别科目成绩日期的数据()
Dim mydata As String
Dim mytable As String
Dim 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 (班级='初一1班' and 性别='男') and (数学>=95 or 语文>=95)" _
& " and year(日期)=2006 and month(日期)=7"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
For i = 1 To rs.Fields.Count
    Cells(1, i) = rs.Fields(i - 1).Name
Next i
Range("a2").CopyFromRecordset rs
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 获取指定科目成绩最高及最低分()
Dim mydata As String
Dim mytable As String
Dim 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 math1,min(数学) as math2 from " & mytable
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
Range("a2:b1") = Array("数学最高分", "数学最低分")
Range("a2:b2") = Array(rs!math1, rs!math2)
rs.Close: cnn.Close
Set cnn = Nothing: Set rs = Nothing
End Sub

jsgj2023

Sub 查询各科的平均分()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim mydata As String
Dim mytable As String
Dim sql As String
Dim i As Integer
Dim classtotal  As Integer
Dim myarray  As Variant
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
classtotal = rs.RecordCount
ReDim myclass(1 To classtotal)
For i = 1 To classtotal
    myclass(i) = rs.Fields("班级")
    rs.MoveNext
Next i
myarray = Array("数学", "语文", "物理", "化学", "英语", "体育", "总分")
Range("a1") = "班级"
Range("b1:h1") = myarray
For i = 1 To classtotal
    Cells(i + 1, 1) = myclass(i)
    For j = 0 To UBound(myarray)
        sql = "select avg(" & myarray(j) & ") as myavg from " & mytable _
        & " where 班级='" & myclass(i) & "'"
        Set rs = New ADODB.Recordset
        rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
        Cells(i + 1, j + 2) = Round(rs!myavg, 2)
    Next j
Next i
rs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 获取指定班级的数学平均分()
Dim mydata As String
Dim mytable As String
Dim 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 *," & "(select avg(数学) as mathavg from " & mytable & " where 班级='初一2班')" & " from " _
& mytable & " where 班级='初一2班'" & " and 数学>=(select avg(数学) from " & mytable & " where 班级='初一2班')"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
For i = 1 To rs.Fields.Count
    Cells(1, i) = rs.Fields(i - 1).Name
Next i
Range("a2").CopyFromRecordset rs
Range("a1") = "班级数学平均分"
rs.Close: cnn.Close: Set cnn = Nothing: Set rs = Nothing
End Sub

jsgj2023

Sub 查询数学成绩大于100且总分大于620的学生()
Dim cnn  As ADODB.Connection
Dim rs  As ADODB.Recordset
Dim myworkname As String
Dim n As Integer
Dim sql As String
Dim ws  As Worksheet
Set ws = Worksheets("汇总")
ws.Cells.Clear
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .ConnectionString = "extended properties=excel 8.0;" _
    & "data source=" & ThisWorkbook.FullName
    .Open
End With
myworkname = Worksheets(2).Name
sql = "select * from [" & myworkname & "$] where 数学>100 and 总分>620"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
If n > 0 Then
    MsgBox "查询到 " & n & " 条符合条件的记录.", vbInformation
Else
    MsgBox "没有查询到符合条件的记录.", vbInformation
End If
For i = 1 To rs.Fields.Count
    ws.Cells(1, i) = rs.Fields(i - 1).Name
Next
ws.Range("a2").CopyFromRecordset rs
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing: Set ws = Nothing
End Sub

jsgj2023

Sub 循环查找工作表中数学成绩大于100且总分大于620的学生名单()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim myworkname As String
Dim n  As Integer
Dim sql As String
Dim ws As Worksheet
Set ws = Worksheets("汇总")
ws.Cells.Clear
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .ConnectionString = "extended properties=excel 8.0;" _
    & "data source=" & ThisWorkbook.FullName
    .Open
End With
For i = 1 To Worksheets.Count
    If Worksheets(i).Name <> "汇总" Then
        myworkname = Worksheets(i).Name
        sql = "select * from [" & myworkname & "$] where 数学>100 and  总分>620"
        Set rs = New ADODB.Recordset
        rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
        For j = 1 To rs.Fields.Count
            ws.Cells(1, j) = rs.Fields(j - 1).Name
        Next
        n = ws.Range("a65536").End(3).Row
        ws.Range("a" & n + 1).CopyFromRecordset rs
    End If
Next
If ws.Range("a65536").End(3).Row > 1 Then
    MsgBox "查询到" & ws.Range("a65536").End(3).Row - 1 _
    & " 条符合条件的记录. ", vbInformation
Else
    MsgBox "没有查询到符合条件的记录. ", vbInformation
End If
End Sub

shijian5600

好东西，留着以后用

jsgj2023

Sub 指定工作簿和工作表查询指定条件学生的成绩()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim myworkname  As String
Dim n  As Integer
Dim sql As String
Dim wbname As String
Dim ws  As Worksheet
Set ws = Worksheets("汇总")
wbname = ThisWorkbook.Path & "\技巧11-001.xls"
ws.Cells.Clear
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .ConnectionString = "extended properties=excle 8.0;" _
    & "data source=" & wbname
    .Open
End With
myworkname = "初一1班"
sql = "select * from [" & myworkname & "$] where 数学>100  and 总分>620"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
If n > 0 Then
    MsgBox "查询到" & n & "条符合条件的记录.", vbInformation
Else
    MsgBox "没有查询到符合条件的记录.", vbInformation
End If
For i = 1 To rs.Fields.Count
    ws.Cells(1, i) = rs.Fields(i - 1).Name
Next
ws.Range("a2").CopyFromRecordset rs
rs.Close
cnn.Close
Set rs = Nothing: Set cnn = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 指定工作簿和工作表查询()
Dim myworkspace As DAO.Workspace
Dim cnn As DAO.Connection
Dim rs As DAO.Recordset
Dim myfilename As String
Dim cnn1 As String
Dim cnn2 As String
Dim cnn3 As String
Dim cnn4 As String
Dim sql As String
Dim i As Long
myfilename = "Adele.xls"
myworkname = "初一1班"
cnn1 = "odbc;"
cnn2 = "dbq=" & ThisWorkbook.Path & "\" & myfilename & ";"
cnn3 = "driver={microsoft excel driver (*.xls)};"
cnn4 = "filedsn=c:"
Set myworkspace = CreateWorkspace("myworkspace", "myname", "", dbUseODBC)
Workspaces.Append myworkspace
sql = "select * from [" & myworkname & "$] where 数学>100 and 总分>620"
Set cnn = myworkspace.OpenConnection( _
Name:="connection", _
Options:=dbDriverNoPrompt, _
Connect:=cnn1 & cnn2 & cnn3 & cnn4)
Set rs = cnn.OpenRecordset(sql)
With rs
    For i = 1 To .Fields.Count
        Cells(1, i).Value = .Fields(i - 1).Name
    Next i
    Range("a2").CopyFromRecordset rs
    .Close
End With
cnn.Close
myworkspace.Close
Set rs = Nothing
Set cnn = Nothing
Set myworkspace = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub ADO法汇总数据()
Dim mypath  As String
Dim defaultpath As String
Dim mysql As String
Dim i As Integer
Dim j  As Integer
Dim n As Integer
Dim p  As Integer
Dim n1  As Integer
Dim n2 As Integer
Dim n3 As Integer
Dim n4 As Integer
Dim cnn As ADODB.Connection
Dim rs  As ADODB.Recordset
Worksheets("原始数据汇总").Cells.Clear
defaultpath = ThisWorkbook.Path & "\初一年级\"
mypath = InputBox("请输入要查询工作簿的文件夹完整目录及名字:" _
& vbCrLf & vbCrLf & "如果为空,则默认为" & vbCrLf _
& defaultpath, "输入路径", defaultpath)
If mypath = "" Then mypath = defaultpath
Application.StatusBar = "正在查找汇总工作簿........"
Set fs = Application.FileSearch
With fs
    .LookIn = mypath
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute(SortBy:=msoSortByFileName, _
        sortorder:=msoSortOrderAscending) > 0 Then
        p = .FoundFiles.Count
        MsgBox "在此文件夹中共有" & p & "个工作表的数据文件需要汇总!", vbInformation, "搜索到汇总文件"
        ReDim myfile(p) As String
        For i = 1 To p
            myfile(i) = .foundfilea(i)
        Next i
    Else
        MsgBox "没有搜索到要汇总的文件!", vbInformation, "没有汇总文件"
        Application.StatusBar = False
        Exit Sub
    End If
End With
For i = 1 To p
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .ConnectionString = "extended properties=excel 8.0;" _
        & "data source=" & myfile(i)
        .Open
    End With
    Set rs = New ADODB.Recordset
    mysql = "select * from [Sheet1$]"
    rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
    If i = 1 Then
        For j = 0 To rs.Fields.Count - 1
            Worksheets("原始数据汇总").Cells(1, j + 1) = rs.Fields(j).Name
        Next
    End If
    n = Worksheets("原始数据汇总").Range("a65536").End(3).Row
    If rs.RecordCount <> 0 Then
        Worksheets("原始数据汇总").Range("a" & n + 1).CopyFromRecordset rs
    End If
Next
Application.StatusBar = False
MsgBox "工作簿汇总完毕!共汇总了" & p & "个工作簿.", vbInformation, "汇总完毕"
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub