VBAコード例1

Private Sub CommandButton1_Click()
'国語
'受験者データベースは受験番号昇順に並べられていること。
Dim mybtn As Integer, myMsg As String, myTitle As String
myTitle = "データ上書き転送の確認"
myMsg = "得点単票中のデータをデータベース" + Chr(13) + "の国語の列に転送します。"
mybtn = MsgBox(myMsg, vbYesNo + vbExclamation, myTitle)
If mybtn <> vbYes Then Exit Sub
Dim dataRange As Object, hyouForm As Object
Set hyouForm = Sheets("志願者データベース")
Set dataRange = Range("得点データ")
maxrec% = Worksheets("諸注意").Range("I15")
rec% = 0
For gyou% = 1 To 3
For retu% = 1 To 3
For no% = 1 To 50
y% = 5 + 59 * (gyou% - 1) + no%
x% = 3 + 5 * (retu% - 1)
L% = 5
r% = maxrec%
If dataRange.Cells(y%, x%).Value <> "" Then
Do While L% <= r%
j% = (L% + r%) / 2
Select Case hyouForm.Cells(j%, 1).Value
Case Is > dataRange.Cells(y%, x%).Value
r% = j% - 1
Case Is < dataRange.Cells(y%, x%).Value
L% = j% + 1
Case dataRange.Cells(y%, x%).Value
hyouForm.Cells(j%, 17).Value = dataRange.Cells(y%, x% + 1).Value
Exit Do
End Select
Loop
End If
Next no%
Next retu%
Next gyou%
myTitle = "確認"
myMsg = "転送完了しました。"
mybtn = MsgBox(myMsg, vbOKOnly + vbExclamation, myTitle)
End Sub
Private Sub CommandButton3_Click()
'教科得点状況一覧表作成
Dim dataRange As Object, hyouForm As Object
Set hyouForm = Sheets("雑諸表")
Set dataRange = Worksheets("志願者データベース").Range("Database")
maxrec% = Worksheets("諸注意").Range("I15")
Dim goukei(0 To 5, 0 To 2, 0 To 2) As Integer
Dim kmax(0 To 5) As Integer
Dim kmin(0 To 5, 0 To 2) As Integer
Dim nin(0 To 5, 0 To 2, 0 To 2) As Integer
For i% = 1 To 5
For j% = 1 To 2
kmin(i%, j%) = 100
Next j%
Next i%
'(教科,大学科,受験・合格)
'(教科)
'(教科,受験・合格)
'(教科,大学科,受験・合格)
For rec% = 1 To maxrec%
Select Case dataRange.Cells(rec%, 11).Value
'第１志望による分岐
Case "普通科"
gakka% = 1
Case "機械科", "電気科", "化工科"
gakka% = 2
Case Else
gakka% = 0
End Select
Select Case dataRange.Cells(rec%, 2).Value
Case "普通科", "機械科", "電気科", "化工科"
'合格者
jg% = 2
Case Else
jg% = 0
End Select
For kamoku% = 1 To 5
If dataRange.Cells(rec%, 16 + kamoku%).Value <> "" Then
goukei(kamoku%, gakka%, 1) = goukei(kamoku%, gakka%, 1) + dataRange.Cells(rec%, 16 + kamoku%).Value
goukei(kamoku%, gakka%, jg%) = goukei(kamoku%, gakka%, jg%) + dataRange.Cells(rec%, 16 + kamoku%).Value
nin(kamoku%, gakka%, jg%) = nin(kamoku%, gakka%, jg%) + 1
nin(kamoku%, gakka%, 1) = nin(kamoku%, gakka%, 1) + 1
If kmax(kamoku%) < dataRange.Cells(rec%, 16 + kamoku%).Value Then
kmax(kamoku%) = dataRange.Cells(rec%, 16 + kamoku%).Value
End If
If kmin(kamoku%, jg%) > dataRange.Cells(rec%, 16 + kamoku%).Value Then
kmin(kamoku%, jg%) = dataRange.Cells(rec%, 16 + kamoku%).Value
End If
If kmin(kamoku%, 1) > dataRange.Cells(rec%, 16 + kamoku%).Value Then
kmin(kamoku%, 1) = dataRange.Cells(rec%, 16 + kamoku%).Value
End If
End If
Next kamoku%
Next rec%
For gakka% = 1 To 2
For jg% = 1 To 2
For kamoku% = 1 To 5
hyouForm.Cells(62 + 2 * (kamoku% - 1), 4 + 2 * (gakka% - 1) + 1 * (jg% - 1)).Value = goukei(kamoku%, gakka%, jg%)
Next kamoku%
Next jg%
Next gakka%
For kamoku% = 1 To 5
hyouForm.Cells(62 + 2 * (kamoku% - 1), 10).Value = kmax(kamoku%)
hyouForm.Cells(62 + 2 * (kamoku% - 1), 11).Value = kmin(kamoku%, 1)
hyouForm.Cells(62 + 2 * (kamoku% - 1), 12).Value = kmin(kamoku%, 2)
Next kamoku%
hyouForm.Cells(72, 4).Value = nin(1, 1, 1)
hyouForm.Cells(72, 5).Value = nin(1, 1, 2)
hyouForm.Cells(72, 6).Value = nin(1, 2, 1)
hyouForm.Cells(72, 7).Value = nin(1, 2, 2)
Dim mybtn As Integer, myMsg As String, myTitle As String
myTitle = "確認"
myMsg = "プリンタの用意はよろしいですか。"
mybtn = MsgBox(myMsg, vbYesNo + vbExclamation, myTitle)
If mybtn = vbYes Then
Range("A58:N72").Select
With ActiveSheet.PageSetup
.Orientation = xlPortrait
End With
Selection.PrintOut Copies:=1, Collate:=True
End If
Range("A58").Select
End Sub

Download Report