日志
Form_计划生摸底成绩分析-cls
||
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Form_计划生摸底成绩分析"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Form_计划生摸底成绩分析"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Private Sub Combo31_Change() '检查变量[combo31]表姓名的重复项
On Error Resume Next
Me.Label30.Caption = "[" & Me.Combo31.Text & "]姓名重复项"
SQL = "SELECT 姓名, 学号,性别, 班级, 语, 数, 外, 理, 化 FROM " & Me.Combo31
SQL = SQL + " WHERE (((姓名) In (SELECT [姓名] FROM " & Me.Combo31 & " As Tmp GROUP BY [姓名] HAVING Count(*)>1 )))"
SQL = SQL + " ORDER BY 姓名;"
Me.Child29.Form.RecordSource = SQL
NN = DCount("*", Me.Combo31, True)
Me.Text33 = Me.Combo31.Text & "共有" & CStr(NN) & "条记录"
End Sub
Private Sub Combo56_Change() '检查变量[combo56]表中与合成表中姓名同音字
On Error Resume Next
sql5 = "SELECT [" & Me.Combo56 & "].学号, [" & Me.Combo56 & "].姓名,[" & Me.Combo56 & "].性别, [" & Me.Combo56 & "].班级 FROM " & Me.Combo56 & " "
sql5 = sql5 + " WHERE ((([" & Me.Combo56 & "].姓名) In (SELECT " & Me.Combo41 & ".姓名"
sql5 = sql5 + " FROM " & Me.Combo41 & " "
sql5 = sql5 + " WHERE (((" & Me.Combo41 & ".拼音) In (SELECT [拼音] FROM [" & Me.Combo41 & "] As Tmp GROUP BY [拼音] HAVING Count(*)>1 )))"
sql5 = sql5 + " ORDER BY " & Me.Combo41 & ".拼音"
sql5 = sql5 + "))) ORDER BY [" & Me.Combo56 & "].姓名;"
On Error Resume Next
sql5 = "SELECT [" & Me.Combo56 & "].学号, [" & Me.Combo56 & "].姓名,[" & Me.Combo56 & "].性别, [" & Me.Combo56 & "].班级 FROM " & Me.Combo56 & " "
sql5 = sql5 + " WHERE ((([" & Me.Combo56 & "].姓名) In (SELECT " & Me.Combo41 & ".姓名"
sql5 = sql5 + " FROM " & Me.Combo41 & " "
sql5 = sql5 + " WHERE (((" & Me.Combo41 & ".拼音) In (SELECT [拼音] FROM [" & Me.Combo41 & "] As Tmp GROUP BY [拼音] HAVING Count(*)>1 )))"
sql5 = sql5 + " ORDER BY " & Me.Combo41 & ".拼音"
sql5 = sql5 + "))) ORDER BY [" & Me.Combo56 & "].姓名;"
Me.Child54.Form.RecordSource = sql5
End Sub
Private Sub Combo62_Change()
On Error Resume Next
Me.Label59.Caption = Me.Combo62 & "成绩表"
End Sub
On Error Resume Next
Me.Label59.Caption = Me.Combo62 & "成绩表"
End Sub
Private Sub Command13_Click()
On Error Resume Next
strFileName = GetFileName("选择EXCEL文件", "*.xls", "xls")
Me.MYBOOKPATH = strFileName
Dim myCat As New ADOX.Catalog
Dim myTbl As ADOX.Table
Dim myBook As String
Dim i As Integer
On Error Resume Next
strFileName = GetFileName("选择EXCEL文件", "*.xls", "xls")
Me.MYBOOKPATH = strFileName
Dim myCat As New ADOX.Catalog
Dim myTbl As ADOX.Table
Dim myBook As String
Dim i As Integer
'指定要查询的工作簿完整名称
myBook = MYBOOKPATH
'建立与指定工作薄的连接
myCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myBook
'开始查询指定工作薄中的工作表名称，并复制到当前工作表
'Cells.Clear
' Range("A1:B1") = Array("查询出的名称", "处理后的名称")
i = 2
For Each myTbl In myCat.Tables
' Cells(i, 1) = myTbl.Name
' Cells(i, 2) = Mid(myTbl.Name, 1, Len(myTbl.Name) - 1)
Me.List18.RowSourceType = "Value List"
'"Table/Query”、“Value List” 或 “Field List”
'Set List18.RowSourceType = 0
' mySheet = Mid(myTbl.Name, 1, Len(myTbl.Name) - 1)
myBook = MYBOOKPATH
'建立与指定工作薄的连接
myCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myBook
'开始查询指定工作薄中的工作表名称，并复制到当前工作表
'Cells.Clear
' Range("A1:B1") = Array("查询出的名称", "处理后的名称")
i = 2
For Each myTbl In myCat.Tables
' Cells(i, 1) = myTbl.Name
' Cells(i, 2) = Mid(myTbl.Name, 1, Len(myTbl.Name) - 1)
Me.List18.RowSourceType = "Value List"
'"Table/Query”、“Value List” 或 “Field List”
'Set List18.RowSourceType = 0
' mySheet = Mid(myTbl.Name, 1, Len(myTbl.Name) - 1)
Me.List18.AddItem myTbl.Name
i = i + 1
Next
'释放变量
Set myCat = Nothing
Set myTbl = Nothing
End Sub
i = i + 1
Next
'释放变量
Set myCat = Nothing
Set myTbl = Nothing
End Sub
Private Sub Command20_Click() '清空工作簿 表名 列表
On Error Resume Next
For i = Me.List18.ListCount - 1 To 0 Step -1
Me.List18.RemoveItem i
Next i
End Sub
On Error Resume Next
For i = Me.List18.ListCount - 1 To 0 Step -1
Me.List18.RemoveItem i
Next i
End Sub
Private Sub Command21_Click() '导入08期中成绩
'工程->引用->Microsoft ActiveX Data Objects 2.X Library
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, BJ, YW, SX, WY, WL, HX As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE [08期中].* FROM 08期中;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
YW = CStr(Nz(rs("语"), 0))
SX = CStr(Nz(rs("数"), 0))
WY = CStr(Nz(rs("外"), 0))
WL = CStr(Nz(rs("理"), 0))
HX = CStr(Nz(rs("化"), 0))
conn.Execute "insert into 08期中(学号,姓名,性别,班级,语,数,外,理,化) values(" & XH & ",'" & XM & "','" & XB & "'," & BJ & "," _
& YW & "," & SX & "," & WY & "," & WL & "," & HX & ")"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[08期中]表导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
'工程->引用->Microsoft ActiveX Data Objects 2.X Library
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, BJ, YW, SX, WY, WL, HX As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE [08期中].* FROM 08期中;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
YW = CStr(Nz(rs("语"), 0))
SX = CStr(Nz(rs("数"), 0))
WY = CStr(Nz(rs("外"), 0))
WL = CStr(Nz(rs("理"), 0))
HX = CStr(Nz(rs("化"), 0))
conn.Execute "insert into 08期中(学号,姓名,性别,班级,语,数,外,理,化) values(" & XH & ",'" & XM & "','" & XB & "'," & BJ & "," _
& YW & "," & SX & "," & WY & "," & WL & "," & HX & ")"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[08期中]表导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
Private Sub Command24_Click() '导入08期末成绩
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, BJ, YW, SX, WY, WL, HX As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE [09期中].* FROM 09期中;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
YW = CStr(Nz(rs("语"), 0))
SX = CStr(Nz(rs("数"), 0))
WY = CStr(Nz(rs("外"), 0))
WL = CStr(Nz(rs("理"), 0))
HX = CStr(Nz(rs("化"), 0))
conn.Execute "insert into 09期中(学号,姓名,性别,班级,语,数,外,理,化) values(" & XH & ",'" & XM & "','" & XB & "'," & BJ & "," _
& YW & "," & SX & "," & WY & "," & WL & "," & HX & ")"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[09期中]表导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
Private Sub Command25_Click() '导入09期中成绩
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, BJ, YW, SX, WY, WL, HX As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE [08期末].* FROM 08期末;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
'XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
YW = CStr(Nz(rs("语"), 0))
SX = CStr(Nz(rs("数"), 0))
WY = CStr(Nz(rs("外"), 0))
WL = CStr(Nz(rs("理"), 0))
HX = CStr(Nz(rs("化"), 0))
conn.Execute "insert into 08期末(学号,姓名,班级,语,数,外,理,化) values('" & XH & "','" & XM & "','" & BJ & "','" _
& YW & "','" & SX & "','" & WY & "','" & WL & "','" & HX & "')"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[08期末]表导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, BJ, YW, SX, WY, WL, HX As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE [08期末].* FROM 08期末;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
'XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
YW = CStr(Nz(rs("语"), 0))
SX = CStr(Nz(rs("数"), 0))
WY = CStr(Nz(rs("外"), 0))
WL = CStr(Nz(rs("理"), 0))
HX = CStr(Nz(rs("化"), 0))
conn.Execute "insert into 08期末(学号,姓名,班级,语,数,外,理,化) values('" & XH & "','" & XM & "','" & BJ & "','" _
& YW & "','" & SX & "','" & WY & "','" & WL & "','" & HX & "')"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[08期末]表导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
Private Sub Command38_Click() '向［ＸＸ中学］表插入三表不重复的姓名
On Error Resume Next
DoCmd.RunSQL ("DELETE * FROM " & Me.Combo41)
sql1 = "INSERT INTO " & Me.Combo41 & "(姓名) SELECT [08期中].姓名 FROM 08期中"
sql1 = sql1 + " WHERE ((([08期中].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
On Error Resume Next
DoCmd.RunSQL ("DELETE * FROM " & Me.Combo41)
sql1 = "INSERT INTO " & Me.Combo41 & "(姓名) SELECT [08期中].姓名 FROM 08期中"
sql1 = sql1 + " WHERE ((([08期中].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
sql2 = "INSERT INTO " & Me.Combo41 & "(姓名) SELECT [08期末].姓名 FROM 08期末"
sql2 = sql2 + " WHERE ((([08期末].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
sql2 = sql2 + " WHERE ((([08期末].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
sql3 = "INSERT INTO " & Me.Combo41 & "(姓名) SELECT [09期中].姓名 FROM 09期中"
sql3 = sql3 + " WHERE ((([09期中].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
DoCmd.RunSQL (sql1)
DoCmd.RunSQL (sql2)
DoCmd.RunSQL (sql3)
sql3 = sql3 + " WHERE ((([09期中].姓名) Not In (select 姓名 from " & Me.Combo41 & ")));"
DoCmd.RunSQL (sql1)
DoCmd.RunSQL (sql2)
DoCmd.RunSQL (sql3)
'更新[XX中学][姓名拼音]
DoCmd.RunSQL ("UPDATE " & Me.Combo41 & " SET 拼音 = hzqp([姓名]);")
DoCmd.RunSQL ("UPDATE " & Me.Combo41 & " SET 拼音 = hzqp([姓名]);")
'更新[XX中学][学号][班级][性别]
DoCmd.RunSQL ("UPDATE " & Me.Combo41 & " INNER JOIN 09期中 ON " & Me.Combo41 & ".姓名 = [09期中].姓名 SET " & Me.Combo41 & ".学号 = [09期中].[学号]," & Me.Combo41 & ".班级 = [09期中].[班级]," & Me.Combo41 & ".性别 = [09期中].[性别];")
DoCmd.RunSQL ("UPDATE " & Me.Combo41 & " INNER JOIN 09期中 ON " & Me.Combo41 & ".姓名 = [09期中].姓名 SET " & Me.Combo41 & ".学号 = [09期中].[学号]," & Me.Combo41 & ".班级 = [09期中].[班级]," & Me.Combo41 & ".性别 = [09期中].[性别];")
'生成[XX中学][姓名拼音]重复项以查姓名多音字错误
sql4 = "SELECT 拼音,学号, 姓名,性别, 班级 FROM " & Me.Combo41
sql4 = sql4 + " WHERE (((拼音) In (SELECT [拼音] FROM [" & Me.Combo41 & "] As Tmp GROUP BY [拼音] HAVING Count(*)>1 )))"
sql4 = sql4 + " ORDER BY 拼音;"
Me.Child52.Form.RecordSource = sql4
End Sub
sql4 = "SELECT 拼音,学号, 姓名,性别, 班级 FROM " & Me.Combo41
sql4 = sql4 + " WHERE (((拼音) In (SELECT [拼音] FROM [" & Me.Combo41 & "] As Tmp GROUP BY [拼音] HAVING Count(*)>1 )))"
sql4 = sql4 + " ORDER BY 拼音;"
Me.Child52.Form.RecordSource = sql4
End Sub
Private Sub Command60_Click() '合并三分表成绩 关键字姓名 更新三分表成绩;生成 [XXX中学]成绩表
On Error Resume Next
sql1 = " UPDATE " & Me.Combo62 & " INNER JOIN 09期中 ON " & Me.Combo62 & ".姓名 = [09期中].姓名 SET "
sql1 = sql1 + Me.Combo62 & ".[09期中语] = [09期中].语, " & Me.Combo62 & ".[09期中数] = [09期中].数, "
sql1 = sql1 + Me.Combo62 & ".[09期中外] = [09期中].外, " & Me.Combo62 & ".[09期中理] = [09期中].理, "
sql1 = sql1 + Me.Combo62 & ".[09期中化] = [09期中].化, " & Me.Combo62 & ".班级 = [09期中].班级;"
On Error Resume Next
sql1 = " UPDATE " & Me.Combo62 & " INNER JOIN 09期中 ON " & Me.Combo62 & ".姓名 = [09期中].姓名 SET "
sql1 = sql1 + Me.Combo62 & ".[09期中语] = [09期中].语, " & Me.Combo62 & ".[09期中数] = [09期中].数, "
sql1 = sql1 + Me.Combo62 & ".[09期中外] = [09期中].外, " & Me.Combo62 & ".[09期中理] = [09期中].理, "
sql1 = sql1 + Me.Combo62 & ".[09期中化] = [09期中].化, " & Me.Combo62 & ".班级 = [09期中].班级;"
sql2 = " UPDATE " & Me.Combo62 & " INNER JOIN 08期中 ON " & Me.Combo62 & ".姓名 = [08期中].姓名 SET "
sql2 = sql2 + Me.Combo62 & ".[08期中语] = [08期中].语, " & Me.Combo62 & ".[08期中数] = [08期中].数, "
sql2 = sql2 + Me.Combo62 & ".[08期中外] = [08期中].外, " & Me.Combo62 & ".[08期中理] = [08期中].理, "
sql2 = sql2 + Me.Combo62 & ".[08期中化] = [08期中].化;"
sql2 = sql2 + Me.Combo62 & ".[08期中语] = [08期中].语, " & Me.Combo62 & ".[08期中数] = [08期中].数, "
sql2 = sql2 + Me.Combo62 & ".[08期中外] = [08期中].外, " & Me.Combo62 & ".[08期中理] = [08期中].理, "
sql2 = sql2 + Me.Combo62 & ".[08期中化] = [08期中].化;"
sql3 = " UPDATE " & Me.Combo62 & " INNER JOIN 08期末 ON " & Me.Combo62 & ".姓名 = [08期末].姓名 SET "
sql3 = sql3 + Me.Combo62 & ".[08期末语] = [08期末].语, " & Me.Combo62 & ".[08期末数] = [08期末].数, "
sql3 = sql3 + Me.Combo62 & ".[08期末外] = [08期末].外, " & Me.Combo62 & ".[08期末理] = [08期末].理, "
sql3 = sql3 + Me.Combo62 & ".[08期末化] = [08期末].化;"
sql3 = sql3 + Me.Combo62 & ".[08期末语] = [08期末].语, " & Me.Combo62 & ".[08期末数] = [08期末].数, "
sql3 = sql3 + Me.Combo62 & ".[08期末外] = [08期末].外, " & Me.Combo62 & ".[08期末理] = [08期末].理, "
sql3 = sql3 + Me.Combo62 & ".[08期末化] = [08期末].化;"
DoCmd.RunSQL (sql1)
DoCmd.RunSQL (sql2)
DoCmd.RunSQL (sql3)
DoCmd.RunSQL (sql2)
DoCmd.RunSQL (sql3)
''成绩合并[XXX中学]成绩表更新结束,计算合成绩
'生成[XXX中学摸底]成绩表
sql5 = "SELECT 学号, 性别,姓名, 班级, cdbl(NZ(([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化]),0)) AS 08期中, "
sql5 = sql5 + " cdbl(NZ(([08期末语]+[08期末数]+[08期末外]+[08期末理]+[08期末化]),0)) AS 08期末, "
sql5 = sql5 + " cdbl(NZ(([09期中语]+[09期中数]+[09期中外]+[09期中理]+[09期中化]),0)) AS 09期中,"
sql5 = sql5 + " cdbl(NZ((([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化])*0.3),0)) AS ['08期中30%'], "
sql5 = sql5 + " cdbl(NZ((([08期末语]+[08期末数]+[08期末外]+[08期末理]+[08期末化])*0.3),0)) AS ['08期末30%'],"
sql5 = sql5 + " cdbl(NZ((([09期中语]+[09期中数]+[09期中外]+[09期中理]+[09期中化])*0.4),0)) AS ['09期中40%'], "
sql5 = sql5 + " cdbl(NZ((([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化])*0.3+([08期末语]+[08期末数]+"
sql5 = sql5 + "[08期末外]+[08期末理]+[08期末化])*0.3 +([09期中语]+[09期中数]+[09期中外]+[09期中理]+"
sql5 = sql5 + "[09期中化])*0.4),0)) AS 总分 into " & Me.Combo62 & "摸底" & " FROM " & Me.Combo62
DoCmd.RunSQL (sql5)
sql5 = "SELECT 学号, 性别,姓名, 班级, cdbl(NZ(([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化]),0)) AS 08期中, "
sql5 = sql5 + " cdbl(NZ(([08期末语]+[08期末数]+[08期末外]+[08期末理]+[08期末化]),0)) AS 08期末, "
sql5 = sql5 + " cdbl(NZ(([09期中语]+[09期中数]+[09期中外]+[09期中理]+[09期中化]),0)) AS 09期中,"
sql5 = sql5 + " cdbl(NZ((([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化])*0.3),0)) AS ['08期中30%'], "
sql5 = sql5 + " cdbl(NZ((([08期末语]+[08期末数]+[08期末外]+[08期末理]+[08期末化])*0.3),0)) AS ['08期末30%'],"
sql5 = sql5 + " cdbl(NZ((([09期中语]+[09期中数]+[09期中外]+[09期中理]+[09期中化])*0.4),0)) AS ['09期中40%'], "
sql5 = sql5 + " cdbl(NZ((([08期中语]+[08期中数]+[08期中外]+[08期中理]+[08期中化])*0.3+([08期末语]+[08期末数]+"
sql5 = sql5 + "[08期末外]+[08期末理]+[08期末化])*0.3 +([09期中语]+[09期中数]+[09期中外]+[09期中理]+"
sql5 = sql5 + "[09期中化])*0.4),0)) AS 总分 into " & Me.Combo62 & "摸底" & " FROM " & Me.Combo62
DoCmd.RunSQL (sql5)
Me.Child58.Requery
'计算名次
sql6 = "SELECT x.*, (select count(*) from [" & Me.Combo62 & "摸底" & " ] where x.总分<总分)+1 AS 名次"
sql6 = sql6 + " FROM " & Me.Combo62 & "摸底" & " AS x"
sql6 = sql6 + " ORDER BY x.总分 DESC;"
'MsgBox (sql6)
'DoCmd.RunSQL (sql6)
'显示 摸底表 含名次
Me.Child58.Form.RecordSource = sql6
End Sub
'计算名次
sql6 = "SELECT x.*, (select count(*) from [" & Me.Combo62 & "摸底" & " ] where x.总分<总分)+1 AS 名次"
sql6 = sql6 + " FROM " & Me.Combo62 & "摸底" & " AS x"
sql6 = sql6 + " ORDER BY x.总分 DESC;"
'MsgBox (sql6)
'DoCmd.RunSQL (sql6)
'显示 摸底表 含名次
Me.Child58.Form.RecordSource = sql6
End Sub
Private Sub Command75_Click() '打印...
On Error Resume Next
Dim strSQL As String
Dim qdf As QueryDef
'删除TEMP查询
For Each Query1 In CurrentDb.QueryDefs
If Query1.Name = Me.Combo69 & "摸底成绩" Then
CurrentDb.QueryDefs.Delete Query1.Name
Exit For
End If
Next Query1
strSQL = "SELECT TOP " & Me.List73 & " DCount('[总分]','" & Me.Combo69 & "摸底','[总分]>' & [总分] & 'and mid(' & [学号] & ',1,4)=" & Me.Text92 & "')+1 AS 名次, 学号, 姓名,性别,班级,[08期中],['08期中30%'],[08期末],['08期末30%'],[09期中],['09期中40%'],总分"
strSQL = strSQL + " FROM " & Me.Combo69 & "摸底"
strSQL = strSQL + " WHERE ((Mid([学号], 1, 4) = " & Me.Text92 & "))"
strSQL = strSQL + " ORDER BY " & Me.Combo69 & "摸底.总分 DESC;"
'MsgBox (strSQL)
On Error Resume Next
Dim strSQL As String
Dim qdf As QueryDef
'删除TEMP查询
For Each Query1 In CurrentDb.QueryDefs
If Query1.Name = Me.Combo69 & "摸底成绩" Then
CurrentDb.QueryDefs.Delete Query1.Name
Exit For
End If
Next Query1
strSQL = "SELECT TOP " & Me.List73 & " DCount('[总分]','" & Me.Combo69 & "摸底','[总分]>' & [总分] & 'and mid(' & [学号] & ',1,4)=" & Me.Text92 & "')+1 AS 名次, 学号, 姓名,性别,班级,[08期中],['08期中30%'],[08期末],['08期末30%'],[09期中],['09期中40%'],总分"
strSQL = strSQL + " FROM " & Me.Combo69 & "摸底"
strSQL = strSQL + " WHERE ((Mid([学号], 1, 4) = " & Me.Text92 & "))"
strSQL = strSQL + " ORDER BY " & Me.Combo69 & "摸底.总分 DESC;"
'MsgBox (strSQL)
'strSQL = "SELECT top " & Me.List73 & " DCount('[总分]','" & Me.Combo69 & "摸底','[总分]>' & [总分])+1 AS 名次, 学号,姓名,性别,班级,[08期中],['08期中30%'],[08期末], ['08期末30%'],[09期中],['09期中40%'],总分"
'strSQL = strSQL + " FROM " & Me.Combo69 & "摸底 ORDER BY 总分 DESC;"
'strSQL = strSQL + " FROM " & Me.Combo69 & "摸底 ORDER BY 总分 DESC;"
Set qdf = CurrentDb.CreateQueryDef(Me.Combo69 & "摸底成绩", strSQL) '创建查询TEMP
'DoCmd.OpenQuery qdf.Name '执行查询
Me.Child67.Form.RecordSource = strSQL
'DoCmd.OutputTo acOutputTable, Me.Combo69 & "摸底成绩", acSpreadsheetTypeExcel9
'DoCmd.OutputTo acOutputTable, [objectname], [outputformat], [outputfile], [autostart]
End Sub
'DoCmd.OpenQuery qdf.Name '执行查询
Me.Child67.Form.RecordSource = strSQL
'DoCmd.OutputTo acOutputTable, Me.Combo69 & "摸底成绩", acSpreadsheetTypeExcel9
'DoCmd.OutputTo acOutputTable, [objectname], [outputformat], [outputfile], [autostart]
End Sub
Private Sub Command78_Click() '退出系统
On Error GoTo Err_Command78_Click
'DoCmd.Close
DoCmd.Quit
Exit_Command78_Click:
Exit Sub
Err_Command78_Click:
MsgBox err.Description
Resume Exit_Command78_Click
End Sub
MsgBox err.Description
Resume Exit_Command78_Click
End Sub
Private Sub Command85_Click() '生成EXCEL表
Dim exFile As String, Shellstg As String
'导出[XX中学摸底成绩]
DoCmd.TransferSpreadsheet acExport, 8, Me.Combo69 & "摸底成绩", CurrentProject.Path & "\" & Me.Combo69, False, ""
'导出[XX中学成绩]
DoCmd.TransferSpreadsheet acExport, 8, Me.Combo69, CurrentProject.Path & "\" & Me.Combo69, False, ""
'导出[XX中学摸底单科]
SQL = "SELECT " & Me.Combo69 & ".*"
SQL = SQL + " FROM " & Me.Combo69 & "摸底成绩 INNER JOIN " & Me.Combo69 & " ON " & Me.Combo69 & "摸底成绩.姓名 = " & Me.Combo69 & ".姓名"
SQL = SQL + " ORDER BY " & Me.Combo69 & "摸底成绩.总分 DESC;"
'建立[XX中学摸底单科]查询
On Error Resume Next
Set qdf = CurrentDb.CreateQueryDef(Me.Combo69 & "摸底单科", SQL) '[XX中学摸底单科]
DoCmd.TransferSpreadsheet acExport, 8, Me.Combo69 & "摸底单科", CurrentProject.Path & "\" & Me.Combo69, False, ""
DoCmd.Close
''请注意引号的用法
Shellstg = """c:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE"" """ & CurrentProject.Path & "\招生.XLS" & """"
Call Shell(Shellstg, 1)
End Sub
SQL = SQL + " FROM " & Me.Combo69 & "摸底成绩 INNER JOIN " & Me.Combo69 & " ON " & Me.Combo69 & "摸底成绩.姓名 = " & Me.Combo69 & ".姓名"
SQL = SQL + " ORDER BY " & Me.Combo69 & "摸底成绩.总分 DESC;"
'建立[XX中学摸底单科]查询
On Error Resume Next
Set qdf = CurrentDb.CreateQueryDef(Me.Combo69 & "摸底单科", SQL) '[XX中学摸底单科]
DoCmd.TransferSpreadsheet acExport, 8, Me.Combo69 & "摸底单科", CurrentProject.Path & "\" & Me.Combo69, False, ""
DoCmd.Close
''请注意引号的用法
Shellstg = """c:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE"" """ & CurrentProject.Path & "\招生.XLS" & """"
Call Shell(Shellstg, 1)
End Sub
Private Sub Command91_Click()
On Error GoTo Err_Command91_Click
On Error GoTo Err_Command91_Click
Dim stDocName As String
Dim stLinkCriteria As String
Dim stLinkCriteria As String
stDocName = "MAIN"
DoCmd.OpenForm stDocName, , , stLinkCriteria
DoCmd.OpenForm stDocName, , , stLinkCriteria
Exit_Command91_Click:
Exit Sub
Exit Sub
Err_Command91_Click:
MsgBox err.Description
Resume Exit_Command91_Click
End Sub
MsgBox err.Description
Resume Exit_Command91_Click
End Sub
Private Sub Command94_Click()
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, XB, BJ, JTZZ, LXR, LXDH As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE " & Me.Combo98 & "报名表.* FROM " & Me.Combo98 & "报名表;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
LXR = IIf(rs("联系人") <> "", rs("联系人"), "*")
JTZZ = IIf(rs("家庭住址") <> "", rs("家庭住址"), "*")
LXDH = IIf(rs("联系电话") <> "", rs("联系电话"), "*")
conn.Execute "insert into " & Me.Combo98 & "报名表(学号,姓名,性别,班级,家庭住址,联系人,联系电话) values(" & XH & ",'" & XM & "','" & XB & "'," & BJ & ",'" _
& JTZZ & "','" & LXR & "','" & LXDH & "')"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[" & Me.Combo98 & "报名表]导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
On Error Resume Next
Dim cnn As New ADODB.Connection
Dim conn As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim mySheet As String
Dim n As Integer
Dim SQL As String
Dim cnnStr As String
Dim myWbName As String
Dim ws As Worksheet
Dim XH, XM, XB, BJ, JTZZ, LXR, LXDH As String
myWbName = Me.MYBOOKPATH '指定要查询的工作簿名称（带完整路径）
'mySheet = Mid(Me.List18, 1, Len(Me.List18) - 1)
mySheet = Me.List18
'指定要查询的工作表名称
' Set ws = Worksheets("查询结果") '指定保存查询结果的工作表
'ws.Cells.Clear
'建立与指定工作簿的连接
cnnStr = "Provider=microsoft.jet.oledb.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & myWbName
cnn.Open cnnStr
Set conn = Application.CurrentProject.Connection
conn.Execute "DELETE " & Me.Combo98 & "报名表.* FROM " & Me.Combo98 & "报名表;"
'设置查询SQL语句
SQL = "select * from [" & mySheet & "]"
'查询符合条件的学生记录
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
On Error GoTo err
Do While Not rs.EOF
'下面的SQL插入语句自行更改，注意数据格式，如果是rs("字段名1")的值是文本，记得在两边加单引号。
XH = CLng(Nz(rs("学号"), 0))
XM = IIf(rs("姓名") <> "", rs("姓名"), "*")
XB = IIf(rs("性别") <> "", rs("性别"), "*")
BJ = CStr(Nz(rs("班级"), 0))
LXR = IIf(rs("联系人") <> "", rs("联系人"), "*")
JTZZ = IIf(rs("家庭住址") <> "", rs("家庭住址"), "*")
LXDH = IIf(rs("联系电话") <> "", rs("联系电话"), "*")
conn.Execute "insert into " & Me.Combo98 & "报名表(学号,姓名,性别,班级,家庭住址,联系人,联系电话) values(" & XH & ",'" & XM & "','" & XB & "'," & BJ & ",'" _
& JTZZ & "','" & LXR & "','" & LXDH & "')"
rs.MoveNext
Loop
rs.Close
cnn.Close
conn.Close
Set rs = Nothing
Set cnn = Nothing
Set ws = Nothing
MsgBox ("[" & Me.Combo98 & "报名表]导入完毕")
Exit Sub
err:
xx = MsgBox("源数据结构出错，请检查:" & err.Description, okonly, "提示")
End Sub
