常用代码归集

jsgj2023

Sub 将重复的数据标示为红色()
Dim myrange As Range
Set myrange = ActiveSheet.Range("a1:a10")
With myrange
    .ClearFormats
    .FormatConditions.AddUniqueValues
    .FormatConditions(1).DupeUnique = xlDuplicate
    With .FormatConditions(1).Font
        .Bold = True
        .Color = vbRed
    End With
End With
Set myrange = Nothing
End Sub

jsgj2023

Sub 标识不重复的数据为红色()
Dim myrange As Range
Set myrange = ActiveSheet.Range("a1:a10")
With myrange
    .ClearFormats
    .FormatConditions.AddUniqueValues
    .FormatConditions(1).DupeUnique = xlUnique
    With .FormatConditions(1).Font
        .Bold = True
        .Color = vbRed
    End With
End With
Set myrange = Nothing
End Sub

jsgj2023

Sub 判断指定的数据库是否存在()
Dim cnn As ADODB.Connection
Dim cnnstr   As String
Dim mydata   As String
mydata = "商品信息"
Set cnn = New ADODB.Connection
cnnstr = "provider=sqloledb.1;" _
& "user id=sa;" _
& "data  source=THTFCOMPUTER;" _
& "Initial Catalog=" & mydata
cnn.ConnectionString = cnnstr
On Error Resume Next
cnn.Open
On Error GoTo 0
If cnn.State = adStateOpen Then
    MsgBox "数据库<" & mydata & ">存在"
    cnn.Close
Else
    MsgBox "数据库<" & mydata & ">不存在"
End If
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 distinct 班级 from " & mytable
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
Range("a1").CopyFromRecordset rs
rs.Close: cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 提取数学成绩大于等于90的前十名_按降序排列()
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
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 10 * from " & mytable & " where 数学>=90  order by 数学 desc"
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
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
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
For i = 1 To rs.Fields.Count
    Cells(1, i) = rs.Fields(i - 1).Name
Next
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 * from " & mytable _
& " order by 总分 desc,数学 desc,语文 desc"
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 统计初一班数学成绩在80至90之间的学生名单()
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 数学 between 80 and 90"
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("a12").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 * 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