常用代码归集

jsgj2023

Sub 增加指定字段的长度()
Dim mydata As String
Dim mytabel  As String
Dim sql As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
mydata = ThisWorkbook.Path & "\职工管理.mdb"
mytable = "职工信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
sql = "alter  table " & mytable & " alter 姓名 text(10)"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
MsgBox "已经将字典<姓名>的长度由5增加到10"
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
mydata = ThisWorkbook.Path & "\职工管理.mdb"
mytable = "职工信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .pen mydata
End With
sql = "alter table " & mytable & " alter 工资 single "
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
MsgBox "字段类型修改完毕"
cnn.Close
Set rs = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 嵌套排序() 'by kagawa
    Dim ar, sr, dic
    Dim i&, j&, k&, m&, n&, r&, s$, s0$, s1$, s2$, t&, w$, z&
    w = InputBox("确认编码分隔符", "按编码分级、并按采购量降序排序", ".")
    ar = [a1].CurrentRegion
    m = UBound(ar)
    s0 = String(Len(CStr(m)), "0")
    ReDim br(2 To m, 1 To 1)
    For i = 2 To m
        s = ar(i, 2)
        sr = Split(s, ".")
        t = UBound(sr): If t > z Then z = t
        br(i, 1) = t
    Next
    [f2].Resize(m - 1) = br
    [a1].Resize(m, 6).Sort [f2], 1, [d2], , 2, [b2], 1, 1
    ReDim b(z)
    Set dic = CreateObject("Scripting.Dictionary")
    ar2 = [a1].CurrentRegion
    For i = 2 To m
        s = ar2(i, 2): t = ar2(i, 6)
        k = b(t) + 1: b(t) = k
        dic(s) = k
        sr = Split(s, ".")
        s1 = "": s2 = "S"
        For j = 0 To IIf(t < z, t, z - 1)
            s1 = s1 & w & sr(j)
            s2 = s2 & Format(dic(Mid(s1, 2)), s0)
        Next
        br(i, 1) = s2
    Next
    [f2].Resize(m - 1) = br
    [a1].Resize(m, 6).Sort [f2], 1, [d2], , 2, [b2], 1, 1
    MsgBox "OK"
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 学号"
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
With Range(Cells(1, 1), Cells(1, rs.Fields.Count))
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With
Range("a2").CopyFromRecordset rs
ActiveSheet.Columns.AutoFit
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
mydata = ThisWorkbook.Path & "\职工管理.mdb"
mytable = "职工信息"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
sql = "alter table " & mytable & " add 提成 currency,扣款 text(50)"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
MsgBox "已为数据表增加2个字段<提成><扣款>"
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 rs  As ADODB.Recordset
Dim cnn As ADODB.Connection
mydata = ThisWorkbook.Path & "\成绩管理.mdb"
mytable = "考试成绩"
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
sql = "update " & mytable & " set  数学=88888 where 学号='CY005'"
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
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
Dim myarray  As Variant
myarray = Array("CY100", "梁橙", "男", "初一5班", 95, 88, 92, 84, 93, 80, 532, #7/6/2006#)
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
Set rs = New ADODB.Recordset
rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
rs.AddNew
For i = 0 To rs.Fields.Count - 1
    rs.Fields(i) = myarray(i)
Next
rs.Update
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 rsx As ADODB.Recordset
Dim i As Long
Dim n   As Long
mydata = ThisWorkbook.Path & "\成绩管理.mdb"
mytable = "考试成绩"
n = Sheets("Sheet1").Range("a65536").End(3).Row
Set cnn = New ADODB.Connection
With cnn
    .Provider = "microsoft.jet.oledb.4.0"
    .Open mydata
End With
mysql = "select* from " & mytable
Set rs = New ADODB.Recordset
rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
For i = 2 To n
sql = "select * from " & mytable & " where 学号='" & Cells(i, 1).Value & "'"
    Set rsx = New ADODB.Recordset
    rsx.Open sql, cnn, adOpenKeyset, adLockOptimistic
    If rsx.RecordCount = 0 Then
        rsx.AddNew
        For j = 1 To rsx.Fields.Count
            rsx.Fields(Cells(1, j).Value) = Cells(i, j).Value
        Next
        rsx.Update
    Else
        For j = 2 To rsx.Fields.Count
            rsx.Fields(j - 1) = Cells(i, j).Value
        Next
        rsx.Update
    End If
Next i
MsgBox "数据保存完毕!", vbInformation + vbOKOnly
rs.Close: cnn.Close
Set rs = Nothing: Set rsx = Nothing: Set cnn = Nothing
End Sub

jsgj2023

Sub 将区域中小于平均值的数字标示为红色()
Dim myrange As Range
Set myrange = ActiveSheet.Range("a1:d10")
With myrange
    .ClearFormats
    .FormatConditions.AddAboveAverage
    .FormatConditions(1).AboveBelow = xlBelowAverage
    With .FormatConditions(1).Font
    .Bold = True
    .Color = vbRed
    End With
End With
Set myrange = Nothing
End Sub

wds1061

感谢收集，谢谢分享