'***************************************************************************************************** ' 定期テスト 成績処理 プログラム ' '90 Jun.(dBASEV) by H.MIYAMOTO ' JITUTES.PRG　 convert to Access '98 Apr. ' 　 convert to Excel '99 Mar.-Apr. '***************************************************************************************************** Sub 成績処理プログラム() '======== ｼｮｷ ｾｯﾃｲ =================================================================================== Dim SSUBR, NSUBR, NSUBC(16), MaxSUBC(17), MinSUBC(17), CNTOT(4), CNSUBC(4, 16) As Single Dim STOT, NTOT, NAVR, CSTOT(4), SSUBC(16), CSSUBC(4, 16) As Long Dim SAVR, AAVR, AV, St(4), STD(4) As Double Dim ALL Sheets("得点").Select '学年人数設定 NU = 1 Do Until Cells(NU + 4, 3) = Cells(4, 3) NU = NU + 1 Loop ALL = NU - 1 For SUBR = 1 To 17 '最小値初期設定 MinSUBC(SUBR) = 100 Next MinSUBC(15) = 1200 '合計最小値設定 '========= ﾒｲﾝ ======================================================================================= 始まり (i) 赤青解除 '--------- ｾｲｾｷ ｹｲｻﾝ --------------------------------------------------------------------------------- Sheets("得点").Select Range("A1").Select For NUMB = 1 To ALL SSUBR = 0 NSUBR = 0 For SUBR = 1 To 14 If Len(Cells(NUMB + 4, SUBR + 3)) > 0 Then 'セル入力値判定 If Cells(NUMB + 4, SUBR + 3) >= 0 And Cells(NUMB + 4, SUBR + 3) <= 100 Then GoSub CALC End If End If Next GoSub CALR Next For NUMB = 1 To ALL '合計、平均の全体及びクラス平均等 For SUBR = 15 To 16 If Cells(NUMB + 4, SUBR + 3) <> "****" Then 'セル入力値判定 GoSub CALC End If Next Next For SUBR = 1 To 16 GoSub PRNVAL Next GoSub PRNVAL2 GoSub STDEV 順位付け 赤青表示 アップダウン クラス番号順並べ替え Sheets("マクロボタン").Select Range("A1").Select 終わり (i) Exit Sub '--------- ｻﾌﾞﾙｰﾁﾝ ---------------------------------------------------------------------------------- CALC: '合計、データ数、最小値、最大値計算 If SUBR <> 3 And SUBR <> 4 And SUBR <> 15 And SUBR <> 16 Then '文章表現、書写等の平均からの除外 SSUBR = SSUBR + Cells(NUMB + 4, SUBR + 3) '個人データ（行方向）計算 NSUBR = NSUBR + 1 End If SSUBC(SUBR) = SSUBC(SUBR) + Cells(NUMB + 4, SUBR + 3) '教科データ（列方向）計算 NSUBC(SUBR) = NSUBC(SUBR) + 1 Select Case Cells(NUMB + 4, 1) Case "Ａ" K = 1 Case "Ｂ" K = 2 Case "Ｃ" K = 3 Case "Ｄ" K = 4 End Select GoSub CALCC1 GoSub MINMAX Return CALCC1: 'クラスデータ計算 CSSUBC(K, SUBR) = CSSUBC(K, SUBR) + Cells(NUMB + 4, SUBR + 3) CNSUBC(K, SUBR) = CNSUBC(K, SUBR) + 1 Return MINMAX: If Val(Cells(NUMB + 4, SUBR + 3)) > 0 Then If MinSUBC(SUBR) > Cells(NUMB + 4, SUBR + 3) Then '最小値計算 MinSUBC(SUBR) = Cells(NUMB + 4, SUBR + 3) End If If MaxSUBC(SUBR) < Cells(NUMB + 4, SUBR + 3) Then '最大値計算 MaxSUBC(SUBR) = Cells(NUMB + 4, SUBR + 3) End If End If Return CALR: '合計、平均値（個人データ）等計算 If NSUBR <> 0 Then AV = SSUBR / NSUBR STOT = STOT + SSUBR NTOT = NTOT + 1 SAVR = SAVR + AV NAVR = NAVR + 1 Cells(NUMB + 4, 18) = SSUBR Cells(NUMB + 4, 19) = AV Cells(NUMB + 4, 25) = NSUBR Else Cells(NUMB + 4, 18) = "****" Cells(NUMB + 4, 19) = "****" Cells(NUMB + 4, 25) = "**" Select Case Cells(NUMB + 4, 1) Case "Ａ" K = 1 Case "Ｂ" K = 2 Case "Ｃ" K = 3 Case "Ｄ" K = 4 End Select GoSub CALCC2 End If Return CALCC2: '合計、データ数（クラスデータ）等計算 CSTOT(K) = CSTOT(K) + STOT CNTOT(K) = CNTOT(K) + 1 Return PRNVAL: '平均値、最大値、最小値（全体及びクラスデータ）等計算、セル入力 If NSUBC(SUBR) > 0 Then Cells(ALL + 7, SUBR + 3) = SSUBC(SUBR) / NSUBC(SUBR) For N = 1 To 4 If CNSUBC(N, SUBR) > 0 Then Cells(ALL + 7 + N, SUBR + 3) = CSSUBC(N, SUBR) / CNSUBC(N, SUBR) Else Cells(ALL + 7 + N, SUBR + 3) = "****" End If Next Cells(ALL + 12, SUBR + 3) = MaxSUBC(SUBR) Cells(ALL + 13, SUBR + 3) = MinSUBC(SUBR) Else For N = 7 To 13 Cells(ALL + N, SUBR + 3) = "****" Next End If Return PRNVAL2: '平均値計算データからの人数のセル入力 Cells(ALL + 7, 21) = NSUBC(16) Cells(ALL + 8, 21) = CNSUBC(1, 16) Cells(ALL + 9, 21) = CNSUBC(2, 16) Cells(ALL + 10, 21) = CNSUBC(3, 16) Cells(ALL + 11, 21) = CNSUBC(4, 16) Return STDEV: '標準偏差、偏差値算出 For NUMB = 1 To ALL K = 0 GoSub CALSTD Select Case Cells(NUMB + 4, 1) Case "Ａ" K = 1 Case "Ｂ" K = 2 Case "Ｃ" K = 3 Case "Ｄ" K = 4 End Select GoSub CALSTD Next For K = 0 To 4 STD(K) = (St(K) / Cells(ALL + 7 + K, 21)) ^ 0.5 Cells(ALL + 7 + K, 20) = STD(K) Next For NUMB = 1 To ALL GoSub CALDEV Next SUBR = 17 For NUMB = 1 To ALL GoSub MINMAX Next Cells(ALL + 12, SUBR + 3) = MaxSUBC(SUBR) Cells(ALL + 13, SUBR + 3) = MinSUBC(SUBR) Return CALSTD: '標準偏差算出 If Len(Cells(NUMB + 4, 19)) > 0 And Cells(NUMB + 4, 19) <> "****" Then St(K) = St(K) + (Cells(NUMB + 4, 19) - Cells(ALL + 7 + K, 19)) * (Cells(NUMB + 4, 19) - Cells(ALL + 7 + K, 19)) End If Return CALDEV: '偏差値算出 If Len(Cells(NUMB + 4, 19)) > 0 And Cells(NUMB + 4, 19) <> "****" Then Cells(NUMB + 4, 20) = 50 + (Cells(NUMB + 4, 19) - Cells(ALL + 7, 19)) * 10 / Cells(ALL + 7, 20) Else Cells(NUMB + 4, 20) = "****" End If Return End Sub Sub 順位付け() '======== ｼﾞｭﾝｲ ===================================================================================== '--------- ｼｮｷ ｾｯﾃｲ --------------------------------------------------------------------------------- Dim REC, RANK, SUBNO As Single Dim CSSUBC(4, 16), RN(4), CT(4) As Long Dim AV(4) As Double Dim ALL Sheets("得点").Select '学年人数設定 NU = 1 Do Until Cells(NU + 4, 3) = Cells(4, 3) NU = NU + 1 Loop ALL = NU - 1 SUBNO = 6 '順位判定を行う最低教科数 RANK = 1 REC = 1 QQ = "***" '--------- ﾒｲﾝ -------------------------------------------------------------------------------------- Worksheets("得点").Range(Cells(5, 1), Cells(ALL + 5, 30)).Sort _ key1:=Worksheets("得点").Range("S5"), Order1:=xlDescending '（キー平均点：文字前） NUMB = 1 Do Until Val(Cells(NUMB + 4, 19)) > 0 '平均をつけてない者（順位をつけない者）の処理 If Val(Cells(NUMB + 4, 19)) > 0 Then Cells(NUMB + 4, 22) = RANK Else Cells(NUMB + 4, 22) = QQ NUMB = NUMB + 1 End If Loop For NUMB = NUMB To ALL '全体順位付け If Cells(NUMB + 4, 25) >= SUBNO Then If Cells(NUMB + 4, 19) = AV(0) Then Cells(NUMB + 4, 22) = RANK REC = REC + 1 Else Cells(NUMB + 4, 22) = REC AV(0) = Cells(NUMB + 4, 19) RANK = REC REC = REC + 1 End If Else Cells(NUMB + 4, 22) = QQ End If Next Worksheets("得点").Range(Cells(5, 1), Cells(ALL + 5, 30)).Sort _ key1:=Worksheets("得点").Range("V5"), Order1:=xlAscending '成績順並べ替え（キー全体順位：文字後） '--------- ｸﾗｽﾍﾞﾂ ｼﾞｭﾝｲ ----------------------------------------------------------------------------- QQ = "**" For K = 1 To 4 AV(K) = Cells(5, 19) RN(K) = 1 CT(K) = 1 Next For NUMB = 1 To ALL 'クラス別順位付け If Cells(NUMB + 4, 22) <> "***" Then Select Case Cells(NUMB + 4, 1) Case "Ａ" K = 1 Case "Ｂ" K = 2 Case "Ｃ" K = 3 Case "Ｄ" K = 4 End Select GoSub CLRANK Else Cells(NUMB + 4, 21) = QQ End If Next Exit Sub CLRANK: If Cells(NUMB + 4, 19) = AV(K) Then Cells(NUMB + 4, 21) = RN(K) CT(K) = CT(K) + 1 Else Cells(NUMB + 4, 21) = CT(K) RN(K) = CT(K) CT(K) = CT(K) + 1 AV(K) = Cells(NUMB + 4, 19) End If Return End Sub '--------- ｻﾌﾞﾙｰﾁﾝ ---------------------------------------------------------------------------------- Sub 始まり(i) With Assistant.NewBalloon .Heading = "アシスタントのカイルです。" .Text = "平均点や順位をつけるプログラムです。処理を開始します。" .Show End With End Sub Sub 終わり(i) With Assistant.NewBalloon .Heading = "お待ちどーさま！" .Text = "成績処理が終わりました。" .Show End With End Sub