Option Explicit
Dim gakunen(99) As Boolean '学年(1~99)
Dim kumi(99, 99) As Long '組 学年(1~99)組(1~99)
Public Sub 自動転記()
Dim str As String
Dim msg As String
Dim test_no As Long
Dim ans As Integer
Dim ms As Worksheet
Dim ws As Worksheet
Dim wrow As Long
Dim wcol As Long
Dim i As Long
Dim j As Long
Dim book_name As String
Dim book_path As String
Dim sheet_name As String
Dim wb As Workbook
Call init_table
str = InputBox("テスト回入力(1~7)")
If str = "" Then Exit Sub
If IsNumeric(str) = False Then Exit Sub
test_no = CLng(str)
If test_no < 1 Or test_no > 7 Then Exit Sub
msg = "第" & test_no & "回テスト結果の集計を実施します"
If MsgBox(msg, vbOKCancel) <> vbOK Then Exit Sub
Set ms = Worksheets("集計")
'集計シートのクラスを記憶
Call set_gakunen(ms, 1)
Call set_gakunen(ms, 7)
Call set_gakunen(ms, 13)
Application.ScreenUpdating = False
'全学年の処理
For i = 1 To 99
If gakunen(i) = True Then
book_name = i & "年テストデータ.xlsx"
book_path = ThisWorkbook.Path & "\" & book_name
If Dir(book_path) = "" Then
MsgBox (book_path & "が存在しません")
Exit Sub
End If
Set wb = Workbooks.Open(book_path)
For j = 1 To 99
If kumi(i, j) <> 0 Then
sheet_name = "普" & j
If check_sheet_name(wb, sheet_name) = False Then
MsgBox (book_name & "内に[" & sheet_name & "]が存在しません")
Exit Sub
End If
Set ws = wb.Worksheets(sheet_name)
Call set_data(ms, test_no, kumi(i, j), ws)
End If
Next
wb.Save
wb.Close
End If
Next
Application.ScreenUpdating = True
MsgBox ("完了")
End Sub
'テーブル初期化
Private Sub init_table()
Dim i As Long
Dim j As Long
For i = 1 To 99
gakunen(i) = False
For j = 1 To 99
kumi(i, j) = 0
Next
Next
End Sub
'学年、組の合計の位置を記憶
Private Sub set_gakunen(ByVal ms As Worksheet, ByVal wcol As Long)
Dim maxrow As Long
Dim wrow As Long
Dim gak As String
Dim key As String
Dim elm As Variant
Dim i As Long
Dim j As Long
maxrow = ms.Cells(Rows.Count, wcol).End(xlUp).Row 'sheetの最大行取得
For wrow = 2 To maxrow
gak = ms.Cells(wrow, wcol).Value
If gak <> "" Then
key = ms.Cells(wrow, wcol + 1).Value
elm = Split(key, "普")
If UBound(elm) <> 1 Then
Call err_msg(ms, wrow, wcol + 1, "集計シート:クラス不正(不正フォーマット)")
End If
If elm(0) <> gak Then
Call err_msg(ms, wrow, wcol + 1, "集計シート:クラス不正(学年不一致)")
End If
If IsNumeric(elm(0)) = False Or IsNumeric(elm(1)) = False Then
Call err_msg(ms, wrow, wcol + 1, "集計シート:クラス不正(学年又は組が数字以外)")
End If
i = CLng(elm(0))
j = CLng(elm(1))
If i < 1 Or i > 99 Or j < 1 Or j > 99 Then
Call err_msg(ms, wrow, wcol + 1, "集計シート:クラス不正(学年又は組が範囲外)")
End If
If kumi(i, j) <> 0 Then
Call err_msg(ms, wrow, wcol + 1, "集計シート:クラス重複")
End If
'合計セルの行番号、列番号を記憶(xxxyyy:xxx=行番号、yyy=列番号)
kumi(i, j) = wrow * 1000 + wcol + 2
gakunen(i) = True
End If
Next
End Sub
'シート名チェック
Private Function check_sheet_name(ByRef wb As Workbook, ByVal sheet_name As String) As Boolean
Dim i As Long
check_sheet_name = True
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Name = sheet_name Then Exit Function
Next
check_sheet_name = False
End Function
'エラー表示及び停止
Private Sub err_msg(ByVal ws As Worksheet, ByVal erow As Long, ByVal ecol As Long, ByVal msg As String)
ws.Activate
ws.Cells(erow, ecol).Select
MsgBox (msg)
End
End Sub
'データ設定(合計、人数、平均)
Private Sub set_data(ByRef ms As Worksheet, ByVal test_no As Long, ByVal row_col As Long, ByRef ws As Worksheet)
Dim srow As Long
Dim scol As Long
Dim wrow As Long
Dim wcol As Long
srow = row_col \ 1000
scol = row_col Mod 1000
wcol = 3 + test_no
For wrow = 45 To 47
ws.Cells(wrow, wcol).Value = ms.Cells(srow, scol).Value
scol = scol + 1
Next
End Sub
T3B0aW9uIEV4cGxpY2l0CiAgICBEaW0gZ2FrdW5lbig5OSkgQXMgQm9vbGVhbiAgICAgICAgICAn5a2m5bm077yIMe+9njk577yJCiAgICBEaW0ga3VtaSg5OSwgOTkpIEFzIExvbmcgICAgICAgICAgICAn57WE44CA5a2m5bm077yIMe+9njk577yJ57WE77yI77yR772eOTnvvIkKUHVibGljIFN1YiDoh6rli5Xou6LoqJgoKQogICAgRGltIHN0ciBBcyBTdHJpbmcKICAgIERpbSBtc2cgQXMgU3RyaW5nCiAgICBEaW0gdGVzdF9ubyBBcyBMb25nCiAgICBEaW0gYW5zIEFzIEludGVnZXIKICAgIERpbSBtcyBBcyBXb3Jrc2hlZXQKICAgIERpbSB3cyBBcyBXb3Jrc2hlZXQKICAgIERpbSB3cm93IEFzIExvbmcKICAgIERpbSB3Y29sIEFzIExvbmcKICAgIERpbSBpIEFzIExvbmcKICAgIERpbSBqIEFzIExvbmcKICAgIERpbSBib29rX25hbWUgQXMgU3RyaW5nCiAgICBEaW0gYm9va19wYXRoIEFzIFN0cmluZwogICAgRGltIHNoZWV0X25hbWUgQXMgU3RyaW5nCiAgICBEaW0gd2IgQXMgV29ya2Jvb2sKICAgIENhbGwgaW5pdF90YWJsZQogICAgc3RyID0gSW5wdXRCb3goIuODhuOCueODiOWbnuWFpeWKmygx772eNykiKQogICAgSWYgc3RyID0gIiIgVGhlbiBFeGl0IFN1YgogICAgSWYgSXNOdW1lcmljKHN0cikgPSBGYWxzZSBUaGVuIEV4aXQgU3ViCiAgICB0ZXN0X25vID0gQ0xuZyhzdHIpCiAgICBJZiB0ZXN0X25vIDwgMSBPciB0ZXN0X25vID4gNyBUaGVuIEV4aXQgU3ViCiAgICBtc2cgPSAi56ysIiAmIHRlc3Rfbm8gJiAi5Zue44OG44K544OI57WQ5p6c44Gu6ZuG6KiI44KS5a6f5pa944GX44G+44GZIgogICAgSWYgTXNnQm94KG1zZywgdmJPS0NhbmNlbCkgPD4gdmJPSyBUaGVuIEV4aXQgU3ViCiAgICBTZXQgbXMgPSBXb3Jrc2hlZXRzKCLpm4boqIgiKQogICAgJ+mbhuioiOOCt+ODvOODiOOBruOCr+ODqeOCueOCkuiomOaGtgogICAgQ2FsbCBzZXRfZ2FrdW5lbihtcywgMSkKICAgIENhbGwgc2V0X2dha3VuZW4obXMsIDcpCiAgICBDYWxsIHNldF9nYWt1bmVuKG1zLCAxMykKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gRmFsc2UKICAgCiAgICAn5YWo5a2m5bm044Gu5Yem55CGCiAgICBGb3IgaSA9IDEgVG8gOTkKICAgICAgICBJZiBnYWt1bmVuKGkpID0gVHJ1ZSBUaGVuCiAgICAgICAgICAgIGJvb2tfbmFtZSA9IGkgJiAi5bm044OG44K544OI44OH44O844K/Lnhsc3giCiAgICAgICAgICAgIGJvb2tfcGF0aCA9IFRoaXNXb3JrYm9vay5QYXRoICYgIlwiICYgYm9va19uYW1lCiAgICAgICAgICAgIElmIERpcihib29rX3BhdGgpID0gIiIgVGhlbgogICAgICAgICAgICAgICAgTXNnQm94IChib29rX3BhdGggJiAi44GM5a2Y5Zyo44GX44G+44Gb44KTIikKICAgICAgICAgICAgICAgIEV4aXQgU3ViCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgICAgICBTZXQgd2IgPSBXb3JrYm9va3MuT3Blbihib29rX3BhdGgpCiAgICAgICAgICAgIEZvciBqID0gMSBUbyA5OQogICAgICAgICAgICAgICAgSWYga3VtaShpLCBqKSA8PiAwIFRoZW4KICAgICAgICAgICAgICAgICAgICBzaGVldF9uYW1lID0gIuaZriIgJiBqCiAgICAgICAgICAgICAgICAgICAgSWYgY2hlY2tfc2hlZXRfbmFtZSh3Yiwgc2hlZXRfbmFtZSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgICAgICAgICAgICAgIE1zZ0JveCAoYm9va19uYW1lICYgIuWGheOBq1siICYgc2hlZXRfbmFtZSAmICJd44GM5a2Y5Zyo44GX44G+44Gb44KTIikKICAgICAgICAgICAgICAgICAgICAgICAgRXhpdCBTdWIKICAgICAgICAgICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgICAgICAgICBTZXQgd3MgPSB3Yi5Xb3Jrc2hlZXRzKHNoZWV0X25hbWUpCiAgICAgICAgICAgICAgICAgICAgQ2FsbCBzZXRfZGF0YShtcywgdGVzdF9ubywga3VtaShpLCBqKSwgd3MpCiAgICAgICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgTmV4dAogICAgICAgICAgICB3Yi5TYXZlCiAgICAgICAgICAgIHdiLkNsb3NlCiAgICAgICAgRW5kIElmCiAgICBOZXh0CiAgICBBcHBsaWNhdGlvbi5TY3JlZW5VcGRhdGluZyA9IFRydWUKICAgIE1zZ0JveCAoIuWujOS6hiIpCkVuZCBTdWIKJ+ODhuODvOODluODq+WIneacn+WMlgpQcml2YXRlIFN1YiBpbml0X3RhYmxlKCkKICAgIERpbSBpIEFzIExvbmcKICAgIERpbSBqIEFzIExvbmcKICAgIEZvciBpID0gMSBUbyA5OQogICAgICAgIGdha3VuZW4oaSkgPSBGYWxzZQogICAgICAgIEZvciBqID0gMSBUbyA5OQogICAgICAgICAgICBrdW1pKGksIGopID0gMAogICAgICAgIE5leHQKICAgIE5leHQKRW5kIFN1Ygon5a2m5bm044CB57WE44Gu5ZCI6KiI44Gu5L2N572u44KS6KiY5oa2ClByaXZhdGUgU3ViIHNldF9nYWt1bmVuKEJ5VmFsIG1zIEFzIFdvcmtzaGVldCwgQnlWYWwgd2NvbCBBcyBMb25nKQogICAgRGltIG1heHJvdyBBcyBMb25nCiAgICBEaW0gd3JvdyBBcyBMb25nCiAgICBEaW0gZ2FrIEFzIFN0cmluZwogICAgRGltIGtleSBBcyBTdHJpbmcKICAgIERpbSBlbG0gQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGogQXMgTG9uZwogICAgbWF4cm93ID0gbXMuQ2VsbHMoUm93cy5Db3VudCwgd2NvbCkuRW5kKHhsVXApLlJvdyAgICAnc2hlZXTjga7mnIDlpKfooYzlj5blvpcKICAgIEZvciB3cm93ID0gMiBUbyBtYXhyb3cKICAgICAgICBnYWsgPSBtcy5DZWxscyh3cm93LCB3Y29sKS5WYWx1ZQogICAgICAgIElmIGdhayA8PiAiIiBUaGVuCiAgICAgICAgICAgIGtleSA9IG1zLkNlbGxzKHdyb3csIHdjb2wgKyAxKS5WYWx1ZQogICAgICAgICAgICBlbG0gPSBTcGxpdChrZXksICLmma4iKQogICAgICAgICAgICBJZiBVQm91bmQoZWxtKSA8PiAxIFRoZW4KICAgICAgICAgICAgICAgIENhbGwgZXJyX21zZyhtcywgd3Jvdywgd2NvbCArIDEsICLpm4boqIjjgrfjg7zjg4jvvJrjgq/jg6njgrnkuI3mraPvvIjkuI3mraPjg5Xjgqnjg7zjg57jg4Pjg4jvvIkiKQogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgSWYgZWxtKDApIDw+IGdhayBUaGVuCiAgICAgICAgICAgICAgICBDYWxsIGVycl9tc2cobXMsIHdyb3csIHdjb2wgKyAxLCAi6ZuG6KiI44K344O844OI77ya44Kv44Op44K55LiN5q2j77yI5a2m5bm05LiN5LiA6Ie077yJIikKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIElmIElzTnVtZXJpYyhlbG0oMCkpID0gRmFsc2UgT3IgSXNOdW1lcmljKGVsbSgxKSkgPSBGYWxzZSBUaGVuCiAgICAgICAgICAgICAgICBDYWxsIGVycl9tc2cobXMsIHdyb3csIHdjb2wgKyAxLCAi6ZuG6KiI44K344O844OI77ya44Kv44Op44K55LiN5q2j77yI5a2m5bm05Y+I44Gv57WE44GM5pWw5a2X5Lul5aSW77yJIikKICAgICAgICAgICAgRW5kIElmCiAgICAgICAgICAgIGkgPSBDTG5nKGVsbSgwKSkKICAgICAgICAgICAgaiA9IENMbmcoZWxtKDEpKQogICAgICAgICAgICBJZiBpIDwgMSBPciBpID4gOTkgT3IgaiA8IDEgT3IgaiA+IDk5IFRoZW4KICAgICAgICAgICAgICAgIENhbGwgZXJyX21zZyhtcywgd3Jvdywgd2NvbCArIDEsICLpm4boqIjjgrfjg7zjg4jvvJrjgq/jg6njgrnkuI3mraPvvIjlrablubTlj4jjga/ntYTjgYznr4Tlm7LlpJbvvIkiKQogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgSWYga3VtaShpLCBqKSA8PiAwIFRoZW4KICAgICAgICAgICAgICAgIENhbGwgZXJyX21zZyhtcywgd3Jvdywgd2NvbCArIDEsICLpm4boqIjjgrfjg7zjg4jvvJrjgq/jg6njgrnph43opIciKQogICAgICAgICAgICBFbmQgSWYKICAgICAgICAgICAgJ+WQiOioiOOCu+ODq+OBruihjOeVquWPt+OAgeWIl+eVquWPt+OCkuiomOaGtih4eHh5eXk6eHh4PeihjOeVquWPt+OAgXl5eT3liJfnlarlj7cpCiAgICAgICAgICAgIGt1bWkoaSwgaikgPSB3cm93ICogMTAwMCArIHdjb2wgKyAyCiAgICAgICAgICAgIGdha3VuZW4oaSkgPSBUcnVlCiAgICAgICAgRW5kIElmCiAgICBOZXh0CkVuZCBTdWIKJ+OCt+ODvOODiOWQjeODgeOCp+ODg+OCrwpQcml2YXRlIEZ1bmN0aW9uIGNoZWNrX3NoZWV0X25hbWUoQnlSZWYgd2IgQXMgV29ya2Jvb2ssIEJ5VmFsIHNoZWV0X25hbWUgQXMgU3RyaW5nKSBBcyBCb29sZWFuCiAgICBEaW0gaSBBcyBMb25nCiAgICBjaGVja19zaGVldF9uYW1lID0gVHJ1ZQogICAgRm9yIGkgPSAxIFRvIHdiLldvcmtzaGVldHMuQ291bnQKICAgICAgICBJZiB3Yi5Xb3Jrc2hlZXRzKGkpLk5hbWUgPSBzaGVldF9uYW1lIFRoZW4gRXhpdCBGdW5jdGlvbgogICAgTmV4dAogICAgY2hlY2tfc2hlZXRfbmFtZSA9IEZhbHNlCkVuZCBGdW5jdGlvbgoKCifjgqjjg6njg7zooajnpLrlj4rjgbPlgZzmraIKUHJpdmF0ZSBTdWIgZXJyX21zZyhCeVZhbCB3cyBBcyBXb3Jrc2hlZXQsIEJ5VmFsIGVyb3cgQXMgTG9uZywgQnlWYWwgZWNvbCBBcyBMb25nLCBCeVZhbCBtc2cgQXMgU3RyaW5nKQogICAgd3MuQWN0aXZhdGUKICAgIHdzLkNlbGxzKGVyb3csIGVjb2wpLlNlbGVjdAogICAgTXNnQm94IChtc2cpCiAgICBFbmQKRW5kIFN1YgoKJ+ODh+ODvOOCv+ioreWumu+8iOWQiOioiOOAgeS6uuaVsOOAgeW5s+Wdh++8iQpQcml2YXRlIFN1YiBzZXRfZGF0YShCeVJlZiBtcyBBcyBXb3Jrc2hlZXQsIEJ5VmFsIHRlc3Rfbm8gQXMgTG9uZywgQnlWYWwgcm93X2NvbCBBcyBMb25nLCBCeVJlZiB3cyBBcyBXb3Jrc2hlZXQpCiAgICBEaW0gc3JvdyBBcyBMb25nCiAgICBEaW0gc2NvbCBBcyBMb25nCiAgICBEaW0gd3JvdyBBcyBMb25nCiAgICBEaW0gd2NvbCBBcyBMb25nCiAgICBzcm93ID0gcm93X2NvbCBcIDEwMDAKICAgIHNjb2wgPSByb3dfY29sIE1vZCAxMDAwCiAgICB3Y29sID0gMyArIHRlc3Rfbm8KICAgIEZvciB3cm93ID0gNDUgVG8gNDcKICAgICAgICB3cy5DZWxscyh3cm93LCB3Y29sKS5WYWx1ZSA9IG1zLkNlbGxzKHNyb3csIHNjb2wpLlZhbHVlCiAgICAgICAgc2NvbCA9IHNjb2wgKyAxCiAgICBOZXh0CkVuZCBTdWIKCg==