适合学习者或具体有中级编程水平的朋友学习
完整代码连接：https://wenku.baidu.com/view/111e5e60760bf78a6529647d27284b73f2423684
'以下为部分代码，要想完美运行去上面连接下载或找Q523857886索取
'公共变量模块
Public ClassName
Public Class
Public n
Public m As Integer
Public p As Integer
'子程序模块
Public Sub 年级班级()
Dim i As Integer, j As Integer, nmax As Integer
Dim ws As Worksheet
Set ws = Worksheets("班级管理")
m = ws.Range("IV1").End(xlToLeft).Column 'End(xlToLeft)是向左查询，直到最后一个非空数据下截止，并将其数值附上。
ReDim n(1 To m) As Integer
ReDim Class(1 To m) As String
nmax = ws.UsedRange.Rows.Count - 1
ReDim ClassName(1 To m, 1 To nmax) As String
For j = 1 To m
n(j) = ws.Cells(65536, j).End(xlUp).Row - 1
Class(j) = ws.Cells(1, j)
For i = 1 To n(j)
ClassName(j, i) = ws.Cells(1 + i, j)
Next i
Next j
End Sub
‘自定义按钮的指定宏模块
Sub 管理学生名单()
Call 管理1.Show
End Sub
Sub 管理学生成绩()
管理学生成绩1.Show
End Sub
Sub 查询学生成绩()
查询学生成绩1.Show
End Sub
Sub 成绩统计分析()
成绩统计分析1.Show
End Sub
Sub 打印成绩单()
Print1.Show
End Sub
Sub 班级管理()
Worksheets("班级管理").Visible = True '显示工作表"班级管理"
Worksheets("班级管理").Activate '激活工作表"班级管理"
End Sub
‘5个窗体
‘管理1 管理学生成绩1 成绩统计1 查询学生成绩1 print1
'管理1
Private Sub CommandButton1_Click()
Dim i As Integer
For i = 1 To TreeView1.Nodes.Count
TreeView1.Nodes(i).Expanded = False
Next
End Sub
Private Sub CommandButton2_Click()
'On Error Resume Next
Dim ws As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim clas As String
Dim classNam As String
'以下功能是发现班级不在就建立所有不在的班级
For j = 1 To m
For i = 1 To n(j)
For k = 1 To Worksheets.Count
If Worksheets(k).Name = Class(j) & Space(1) & ClassName(j, i) Then Exit For
Next k
If k > Worksheets.Count Then 'k>count说明没找到对应班级，所以要建立班级
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Class(j) & Space(1) & ClassName(j, i)
Range("A1:k1").Select
Selection = Array("学号", "姓名 ", "性别 ", "数学 ", "语文 ", "英语 ", "物理 ", "化学 ", "生物", "体育", "总分")
Selection.HorizontalAlignment = xlCenter '标题文字居中
Columns("A:A").NumberFormatLocal = "@" 'A列数据为文本
End If
Next i
Next j
Worksheets("首页").Activate
ActiveSheet.Range("A2").Select
End Sub
Private Sub CommandButton3_Click()
End
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
'显示并激活某班工作表
Dim i As Integer
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "首页" And Worksheets(i).Name <> Node.Key Then
Worksheets(i).Visible = False '保护除工作表“首页”外的所有工作表
End If
Next i
Worksheets(Node.Key).Visible = True
Worksheets(Node.Key).Activate
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer, j As Integer
Call 年级班级
TreeView1.Nodes.Clear
TreeView1.LineStyle = tvwRootLines
TreeView1.LabelEdit = tvwManual
For j = 1 To m
Set nodx = TreeView1.Nodes.Add(, , Class(j), Class(j))
Next j
For j = 1 To m
For i = 1 To n(j)
Set nodx = TreeView1.Nodes.Add(Class(j), tvwChild, Class(j) & Space(1) & ClassName(j, i), ClassName(j, i))
Next i
Next j
End Sub
‘管理学生成绩1
Dim myText As String
Dim myName As String
Dim ws As Worksheet
Dim myArray As Variant
Private Sub CommandButton1_Click()
Dim i As Integer
For i = 1 To TreeView1.Nodes.Count
TreeView1.Nodes(i).Expanded = False
Next
Call 清除窗口
End Sub
Private Sub CommandButton2_Click()
Call 清除窗口
End Sub
Private Sub CommandButton3_Click()
Dim cel As Range, i As Integer
If 班级.Value = "" Then
MsgBox "班级不能为空", vbOKOnly, "提示信息"
Exit Sub
Else
End If
For i = 1 To Worksheets.Count
If Worksheets(i).Name = 班级.Value Then Exit For
Next i
If i > Worksheets.Count Then
MsgBox "班级不存在", vbOKOnly, "提示信息"
Exit Sub
Exit Sub
End If
'保存学生信息
Set ws = Worksheets(班级.Value)
p = ws.Range("b65536").End(xlUp).Row - 1
For Each cel In ws.Range("A2:A" & p + 1)
If cel.Text = 学号.Value Then
For i = 1 To UBound(myArray)
cel.Offset(0, i) = Me.Controls(myArray(i)).Value
Next i
GoTo HHHH
End If
Next
'添加新数据
p = ws.Range("B65536").End(xlUp).Row
For i = 1 To UBound(myArray) + 1
Cells(p + 1, i) = Me.Controls(myArray(i - 1)).Value
Next
HHH:
Call 设置节点
For i = 1 To m
If TreeView1.Nodes(i).Key = Class(i) Then
TreeView1.Nodes(i).Expanded = True
Exit For
End If
Next i
HHHH:
End Sub
Private Sub CommandButton4_Click()
End
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
Dim tem
Dim str As String
Dim cel As Range
myText = Node.Parent.Parent.Text & Space(1) & Node.Parent.Text
myName = Node.Text
Set ws = Worksheets(myText)
ws.Visible = xlSheetVisible
ws.Activate
'在工作表中查找此学生，并将查询到的学生信息显示在窗体上
p = ws.Range("B65536").End(xlUp).Row - 1
For Each cel In ws.Range("B2:B" & p + 1)
If cel.Text = myName Then
班级.Value = myText
For i = 0 To UBound(myArray)
Me.Controls(myArray(i)).Value = cel.Offset(0, i - 1)
Next i
Rows(cel.Row).Select
Exit For
Else
Call 清除窗口
End If
Next
Call 总分计算
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "首页" And Worksheets(i).Name <> Node.Key Then
'Worksheets(i).Visible = False '保护除工作表“首页”外的所有工作表
End If
Next i
Worksheets(Node.Key).Visible = True
Worksheets(Node.Key).Activate
tem = Split(Node.Key, "班")
If UBound(tem) = 1 Then
str = tem(0)
班级.Value = str & "班"
Worksheets(班级.Value).Activate
End If
End Sub
Public Sub 清除窗口()
Dim i As Integer
班级.Value = ""
For i = 0 To UBound(myArray)
Me.Controls(myArray(i)).Value = ""
Next i
End Sub
Public Sub 总分计算()
总分.Value = Val(数学.Value)
总分.Value = 总分.Value + Val(语文.Value)
总分.Value = 总分.Value + Val(英语.Value)
总分.Value = 总分.Value + Val(物理.Value)
总分.Value = 总分.Value + Val(化学.Value)
总分.Value = 总分.Value + Val(生物.Value)
总分.Value = 总分.Value + Val(体育.Value)
End Sub
Private Sub UserForm_Initialize()
'On Error Resume Next
myArray = Array("学号", "姓名", "性别", "数学", "语文", "英语", "物理", "化学", "生物", "体育", "总分")
Call 设置节点
End Sub
Public Sub 设置节点()
Dim i As Integer, j As Integer, k As Integer, p As Integer
Dim mystr As String
Call 年级班级
TreeView1.Nodes.Clear
'设置Treeview1 控件属性
TreeView1.LineStyle = tvwRootLines
TreeView1.LabelEdit = tvwManual
For j = 1 To m
Set nodx = TreeView1.Nodes.Add(, , Class(j), Class(j))
Next j
For j = 1 To m
For i = 1 To n(j)
Set nodx = TreeView1.Nodes.Add(Class(j), tvwChild, Class(j) & Space(1) & ClassName(j, i), ClassName(j, i))
Next i
Next j
For j = 1 To m
For i = 1 To n(j)
'查某个班的学生数
mystr = Class(j) & Space(1) & ClassName(j, i)
Set ws = Worksheets(mystr)
p = ws.Range("B65536").End(xlUp).Row - 1
For k = 1 To p
Set nodx = TreeView1.Nodes.Add(mystr, tvwChild, mystr & k, ws.Range("B" & k + 1))
Next k
Next i
Next j
End Sub
Private Sub 体育_Change()
Call 总分计算
End Sub
Private Sub 化学_Change()
Call 总分计算
End Sub
Private Sub 总分_Change()
End Sub
Private Sub 总分_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call 总分计算
End Sub
Private Sub 数学_Change()
Call 总分计算
End Sub
Private Sub 物理_Change()
Call 总分计算
End Sub
Private Sub 班级_Change()
End Sub
Private Sub 生物_Change()
Call 总分计算
End Sub
Private Sub 英语_Change()
Call 总分计算
End Sub
Private Sub 语文_Change()
Call 总分计算
End Sub
’成绩统计分析1
Dim myArray As Variant
Private Sub CommandButton1_Click()
Dim SheetExist As Boolean
Dim ws As Worksheet
Dim finalRow As Integer, i As Integer, k As Integer
Dim myCondition As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
'判断工作簿中是否存在"统计分析结果"工作表
SheetExist = False
For Each ws In Worksheets
If ws.Name = "统计分析结果" Then
SheetExist = True: Exit For
End If
Next
If SheetExist = False Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "统计分析结果"
End If
Set ws = Worksheets("统计分析结果")
ws.Visible = xlSheetVisible
ws.Activate
ws.Cells.Clear
myCondition = "WHERE " & 学科.Value
If 比较符.Value = "between" Then
myCondition = myCondition & " between " & Val(条件1.Value) & " and " & Val(条件2.Value)
Else
myCondition = myCondition & 比较符.Value & Val(条件1.Value)
End If
'建立与当前工作簿的连接
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
'输入标题
ws.Range("A1:E1") = Array(" 班级", "学号", "姓名", "性别", 学科.Value)
'根据选择的统计分析要求，查询数据并复制到工作表"统计分析结果"中
If 选择班级.Value = "全年级" Then
For i = 1 To Worksheets.Count
If Worksheets(i).Name = "首页" Or Worksheets(i).Name = "班级管理" Or Worksheets(i).Name = "统计分析结果" Or InStr(Worksheets(i).Name, 选择年级.Value) = 0 Then GoTo myNext
mysql = "select 学号,姓名,性别," & 学科.Value & " from [" & Worksheets(i).Name & "$] " & myCondition & " order by " & 学科.Value & " DESC"
Set rs = New ADODB.Recordset
rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
finalRow = ws.Range("A65536").End(xlUp).Row
If rs.RecordCount > 0 Then
For k = 1 To rs.RecordCount
ws.Range("A" & k + finalRow) = Worksheets(i).Name
Next k
'复制查询到的数据
ws.Range("B" & finalRow + 1).CopyFromRecordset rs
End If
myNext:
Next i
Else
mysql = "SELECT 学号,姓名,性别," & 学科.Value & " FROM [" & 选择年级.Value & Space(1) & 选择班级.Value & "$] " & myCondition & " order by " & 学科.Value & " DESC"
Set rs = New ADODB.Recordset
rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
finalRow = ws.Range("A65536").End(xlUp).Row
If rs.RecordCount > 0 Then
ws.Range("A" & finalRow + 1) = 选择班级.Value
ws.Range("B" & finalRow + 1).CopyFromRecordset rs
Else
MsgBox "没有查到符合条件的学生!", vbInformation, "没有记录"
End If
End If
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
End
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
Dim j As Integer
Set wb = ThisWorkbook
Call 年级班级
For j = 1 To m
选择年级.AddItem Class(j)
Next j
选择年级.ListIndex = 0
'为查询项目复合框设置项目
myArray = Array("数学", "语文", "英语", "物理", "化学", "生物", "体育", "总分")
For j = 0 To UBound(myArray)
学科.AddItem myArray(j)
Next j
学科.ListIndex = 0
'为查询条件复合框设置项目
With 比较符
.AddItem "="
.AddItem ">"
.AddItem "<"
.AddItem "between"
End With
比较符.ListIndex = 0
End Sub
Private Sub 学科_Change()
End Sub
Private Sub 学科_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 比较符_Change()
If 比较符.Value = "between" Then
与.Visible = True: 条件2.Visible = True: 条件1.Width = 72
Else
与.Visible = False: 条件2.Visible = False: 条件1.Width = 90
End If
条件1.SetFocus
End Sub
Private Sub 比较符_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 选择年级_Change()
Dim i As Integer
'为选择班级复合框设置项目
选择班级.Clear
For i = 1 To n(选择年级.ListIndex + 1)
选择班级.AddItem ClassName(选择年级.ListIndex + 1, i)
Next i
选择班级.AddItem "全年级"
选择班级.ListIndex = 0
End Sub
Private Sub 选择年级_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 选择班级_Change()
End Sub
Private Sub 选择班级_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
‘查询学生成绩1
Dim myArray
Dim myRow As Integer
Dim ws As Worksheet
Private Sub Label8_Click()
End Sub
Private Sub 查询_Click()
On Error Resume Next
Dim myColumn As Integer
Set ws = Worksheets(查询年级.Value & Space(1) & 查询班级.Value)
ws.Visible = xlSheetVisible
ws.Activate
If 查询.Caption = "查询" Then
myRow = 2
Rows(myRow).Select
End If
myColumn = 查询项目.ListIndex + 4
For i = myRow To ws.Range("A65536").End(xlUp).Row
If 查询条件.Value = "大于" Then
If Val(Cells(i, myColumn).Value) > Val(条件值.Value) Then
Call 查询显示(Cells(i, myColumn), myColumn)
myRow = Cells(i, myColumn).Row + 1
Rows(myRow - 1).Select
查询.Caption = "查找下一个"
Exit Sub
End If
ElseIf 查询条件.Value = "等于" Then
If Val(Cells(i, myColumn).Value) = Val(条件值.Value) Then
Call 查询显示(Cells(i, myColumn), myColumn)
myRow = Cells(i, myColumn).Row + 1
Rows(myRow - 1).Select
查询.Caption = "查找下一个"
Exit Sub
End If
ElseIf 查询条件.Value = "小于" Then
If Val(Cells(i, myColumn).Value) < Val(条件值.Value) Then
Call 查询显示(Cells(i, myColumn), myColumn)
myRow = Cells(i, myColumn).Row + 1
Rows(myRow - 1).Select
查询.Caption = "查找下一个"
Exit Sub
End If
End If
Next i
MsgBox "没有查询的结果！", vbExclamation, "无查询结果"
查询.Caption = "查询"
End Sub
Public Sub 查询显示(mycel As Range, myCol As Integer)
姓名.Value = Cells(mycel.Row, 2)
性别.Value = Cells(mycel.Row, 3)
Label8.Caption = 查询项目.Value & "分数:"
项目结果.Value = Cells(mycel.Row, myCol)
End Sub
Private Sub CommandButton2_Click()
End
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
Dim j As Integer
Call 年级班级
For j = 1 To m
查询年级.AddItem Class(j)
Next j
查询年级.ListIndex = 0
'为查询项目复合框设置项目
myArray = Array("数学", "语文", "英语", "物理", "化学", "生物", "体育", "总分")
For j = 0 To UBound(myArray)
查询项目.AddItem myArray(j)
Next j
查询项目.ListIndex = 0
'为查询条件复合框设置项目
With 查询条件
.AddItem "大于"
.AddItem "等于"
.AddItem "小于"
End With
查询条件.ListIndex = 0
End Sub
Private Sub 查询年级_Change()
Dim i As Integer
'为查询班级复合框设置项目
查询班级.Clear
For i = 1 To n(查询年级.ListIndex + 1)
查询班级.AddItem ClassName(查询年级.ListIndex + 1, i)
Next i
查询班级.ListIndex = 0
End Sub
Private Sub 查询年级_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 查询条件_Change()
End Sub
Private Sub 查询条件_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 查询班级_Change()
End Sub
Private Sub 查询班级_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
Private Sub 查询项目_Change()
End Sub
Private Sub 查询项目_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = 0
End Sub
网友评论