時間割マクロ完成

2022年4月1日 22:41

　この間の時間割マクロの話を読まれたかたは、お読みにならなくてもだいじょうぶですよ。あれには不備があったので、あらためて書くだけですから。

　学校の時間割を作成するマクロ、ついに完成しました。先日のものは、不具合があることに気づいたのです。きのう、就労移行で必死に考えました。

　ついに原因をつきとめました。ForからNextという繰り返しのなかで、変わってはいけない文字列の変数が、途中で変わっていました。そこだけ変数の名前を変えることで解決しました。なさけない間違いというか「よくそんな根源的な間違いをしているのに、いままで何事もなく走っていたな」と思うような間違いでした。気がついてよかったです。

　そして、年度末のきのう、実際に使用する人と打ち合わせて、少し仕様を作り変えました。また、年度始めの本日、もう一度、問い合わせがあって、もう少し仕様を変えてリリースしました。おそらくこれでだいじょうぶであるはず…。

　自分の作ったマクロが、ほんとうに誰かの役に立つのは初めてではないでしょうか。うれしいです。

　以下にコードをさらしますね。律儀に読み解かなくてだいじょうぶですよ（笑）。

Sub 時間割()
Dim i As Integer
Dim j As Integer
Dim HRyoubimoji(6) As String
Dim HRyoubi(6) As Integer

Dim HR(6) As Integer

Dim hrc As Integer

Dim tantoushanokazu, classnokazu As Integer
Dim gakunenmoji As String
Dim nenkumi As String

Dim nenkumitanclass As String

Dim classonly As String
Dim classsentakuonly As String
Dim tanclass As String

Dim nagasa As Integer
Dim jigen As String
Dim namae As String
Dim tanjigen As String
Dim taiiku As String
Dim ninzuu As String

Dim s As Integer
Dim t As Integer
Dim p, pp As Integer
Dim n As Integer

Dim myrange As Range
Dim myobj As Range

Dim myrangehr As Range
Dim myobjhr As Range
Dim mycellhr As Range
Dim HRstr As String
Dim mycellhrretu As Integer

Dim myrangesentaku As Range
Dim myobjsentaku As Range
Dim sentakustr As String
Dim senpstr(10) As String
Dim senqstr(10) As String
Dim banti As String

Dim sentaku(10) As Integer
Dim sentakugyou As Integer
Dim q, r, ss, sss, x, nn As Integer
Dim hajimarisentaku, owarisentaku As String

Dim sentakukyouka As String
Dim gijututaiiku As String

gijututaiiku = "体育"

Dim iro1(3), iro2(3), iro3(3), iro4(3), iro5(3), iro6(3), iroHR(3), iropink(3), iroHS(3), irokuuran(3), irokaigi(3) As Integer
Dim irosen(3), irokyoukakan(3), iros(3), iroh(3), iroj(3) As Integer

iropink(1) = 255
iropink(2) = 192
iropink(3) = 203

iro1(1) = 248
iro1(2) = 198
iro1(3) = 32

iro2(1) = 152
iro2(2) = 251
iro2(3) = 152

iro3(1) = 0
iro3(2) = 255
iro3(3) = 255

iro4(1) = 230
iro4(2) = 230
iro4(3) = 250

iro5(1) = 245
iro5(2) = 245
iro5(3) = 220

iro6(1) = 216
iro6(2) = 191
iro6(3) = 216

iroHS(1) = 0
iroHS(2) = 128
iroHS(3) = 0

iroHR(1) = 255
iroHR(2) = 250
iroHR(3) = 250

irokaigi(1) = 255
irokaigi(2) = 255
irokaigi(3) = 0

irokuuran(1) = 255
irokuuran(2) = 255
irokuuran(3) = 255

iros(1) = 255
iros(2) = 255
iros(3) = 255

iroh(1) = 255
iroh(2) = 255
iroh(3) = 255

iroj(1) = 255
iroj(2) = 255
iroj(3) = 255

irosen(1) = 255
irosen(2) = 255
irosen(3) = 255

irokyoukakan(1) = 255
irokyoukakan(2) = 0
irokyoukakan(3) = 0

Dim iro As String
Dim irogakunen As Integer

Sheets("全担当者").Select
tantoushanokazu = WorksheetFunction.CountIf(Range("B2:B500"), "<>")
Sheets("全組").Select
classnokazu = WorksheetFunction.CountIf(Range("A2:A100"), "<>")

Worksheets("全組").Range("B2:AN" & classnokazu + 1).ClearContents

Worksheets("全担当者").Range("A1:A" & tantoushanokazu + 1).HorizontalAlignment = xlCenter
Worksheets("全組").Range("B2:AN" & classnokazu + 1).HorizontalAlignment = xlCenter

Worksheets("全組").Range("B2:AN" & classnokazu + 1).ShrinkToFit = True

'ホームルームをつくる

For hrc = 1 To 6
' Do
' HRyoubimoji(hrc) = InputBox(hrc & "年生のホームルームは何曜日ですか。" & vbCrLf & "1.月、2.火、3.水、4.木、5.金、6.土")
' HRyoubi(hrc) = Val(HRyoubimoji(hrc))
' Loop While HRyoubi(hrc) < 1 Or HRyoubi(hrc) > 6
HRyoubi(1) = 3
HRyoubi(2) = 3
HRyoubi(3) = 3
HRyoubi(4) = 5
HRyoubi(5) = 2
HRyoubi(6) = 1

HR(hrc) = 7 * HRyoubi(hrc) - 5

Set myrangehr = Worksheets("全組").Range("A1:AN" & classnokazu + 1)
Set myobjhr = myrangehr.Find(hrc, LookAt:=xlPart)

If myobjhr Is Nothing Then
MsgBox "「全組」シートの学年に間違いがあります"
Exit Sub
End If

Set mycellhr = myobjhr

Do
mycellhrretu = mycellhr.Row
' MsgBox mycellhrretu
' MsgBox HR(hrc)
HRstr = Worksheets("全組").Cells(mycellhrretu, HR(hrc)).Address(False, False)
' MsgBox HRstr
Worksheets("全組").Range(HRstr).Value = "HR"
Set mycellhr = myrangehr.FindNext(mycellhr)
Loop While mycellhr.Row <> myobjhr.Row
Next

'とりあえず従来型のようにつくる

Set myrange = Worksheets("全組").Range("A1:A" & classnokazu + 1)

For i = 2 To tantoushanokazu + 1
For j = 3 To 41

nenkumi = Worksheets("全担当者").Cells(i, j).Value

If nenkumi <> "" Then
' gakunenmoji = Left(nenkumi, 1)
' If IsNumeric(gakunenmoji) = False Then
' If nenkumi = "HR" Then

If IsNumeric(Left(nenkumi, 1)) = True Then

gakunenmoji = Left(nenkumi, 1)
gakunen = Val(gakunenmoji)

classonly = Mid(nenkumi, 2)
nagasa = Len(classonly)

If Right(classonly, 1) = "s" Or Right(classonly, 1) = "h" Or Right(classonly, 1) = "j" Or Right(classonly, 1) = "i" Then
' classsentakuonly = Left(classonly, nagasa - 1)
nagasa = nagasa - 1
Select Case Right(classonly, 1)
Case "s"
taiiku = "(水)"
Case "h"
taiiku = "(保)"
Case "j"
taiiku = "(柔)"
Case "i"
taiiku = "(情)"
End Select
classonly = Left(classonly, nagasa)
ElseIf UCase(Right(classonly, 1)) <> Right(classonly, 1) Then
taiiku = ""
nagasa = nagasa - 1
classonly = Left(classonly, nagasa)
Else

taiiku = ""
End If

' If nagasa = 1 Then
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
' t = j - 1
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' MsgBox s & t & namae
' Worksheets("全組").Cells(s, t) = namae
' Else

jigen = Worksheets("全担当者").Cells(1, j).Value
namae = Worksheets("全担当者").Cells(i, 2).Value
t = j - 1

For p = 1 To nagasa

tanclass = Mid(classonly, p, 1)
nenkumi = gakunenmoji & tanclass
Set myobj = myrange.Find(nenkumi, , , xlPart)
If myobj Is Nothing Then
MsgBox "存在しないクラスが書いてあります"
Exit Sub
End If

s = myobj.Row
Worksheets("全組").Cells(s, t) = namae & taiiku
Next
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
' t = j - 1
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' Worksheets("全組").Cells(s, t) = namae & taiiku
' Else
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = "選択" & Worksheets("全担当者").Cells(i, 1).MergeArea(1, 1).Value
' t = j - 1

' For p = 1 To nagasa

' tanclass = Mid(classsentakuonly, p, 1)
' nenkumi = gakunenmoji & tanclass
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' Worksheets("全組").Cells(s, t) = namae & taiiku
' Next

End If
End If

Next
Next

'従来型マクロはできた。ここから選択社会や教科間選択

For i = 1 To 10
sentaku(i) = 0
Next

For j = 3 To 41
hajimarisentaku = Cells(2, j).Address
owarisentaku = Cells(tantoushanokazu + 1, j).Address
' Set myrangesentaku = Worksheets("全担当者").Range(Cells(2, 3), Cells(200, 3))
Set myrangesentaku = Worksheets("全担当者").Range(hajimarisentaku & ":" & owarisentaku)

For i = 2 To tantoushanokazu + 1
L1:
If i > tantoushanokazu + 1 Then
Exit For
End If

For nn = 1 To 10
sentaku(nn) = 0
Next

nenkumi = Worksheets("全担当者").Cells(i, j).Value

If nenkumi = "HR" Or nenkumi = "*" Or nenkumi = "＊" Or nenkumi = "" Or nenkumi = "HS" Then
i = i + 1
GoTo L1
End If
If Val(Left(nenkumi, 1)) <> 1 And Val(Left(nenkumi, 1)) <> 2 And Val(Left(nenkumi, 1)) <> 3 And Val(Left(nenkumi, 1)) <> 4 And Val(Left(nenkumi, 1)) <> 5 And Val(Left(nenkumi, 1)) <> 6 Then
i = i + 1
GoTo L1
End If

Set myobjsentaku = myrangesentaku.Find(nenkumi, , , xlPart)

If Not myobjsentaku Is Nothing Then
' If myobjswentaku.Address(False, False) = Range(Cells(i, j), Cells(i, j)).Value Then
' i = i + 1
' GoTo L1
' End If
sentaku(1) = myobjsentaku.Row
If sentaku(1) = i Then
i = i + 1
GoTo L1
End If

n = 2
banti = myobjsentaku.Address

Do

Set myobjsentaku = myrangesentaku.FindNext(myobjsentaku)
If myobjsentaku Is Nothing Then
Exit Do
End If
sentaku(n) = myobjsentaku.Row
n = n + 1
Loop While myobjsentaku.Address <> banti
n = n - 1
For q = 1 To n
If sentaku(q) = 0 Then
Exit For
End If

senpstr(q) = Worksheets("全担当者").Cells(sentaku(q), 1).MergeArea(1, 1).Value
If InStr(senpstr(q), "技") <> 0 Then
senpstr(q) = gijututaiiku
End If

Next
x = 0
For ss = 1 To n
For sss = 1 To n
If senpstr(ss) <> senpstr(sss) Then
x = x + 1
End If
Next
Next

If x = 0 Then
jigen = Worksheets("全担当者").Cells(1, j).Value
sentakukyouka = Worksheets("全担当者").Cells(i, 1).MergeArea(1, 1).Value
If InStr(sentakukyouka, "技") <> 0 Then
sentakukyouka = gijututaiiku
End If

namae = "選択" & sentakukyouka

t = j - 1

For p = 1 To n

'　昼休み。nenkumiは4Aとか4ABとかなので、全組シートにsとtで表さねばならない。

If Right(nenkumi, 1) = "s" Or Right(nenkumi, 1) = "h" Or Right(nenkumi, 1) = "j" Or Right(nenkumi, 1) = "i" Then
' classsentakuonly = Left(classonly, nagasa - 1)
' nagasa = nagasa - 1
Select Case Right(nenkumi, 1)
Case "s"
taiiku = "(水)"
Case "h"
taiiku = "(保)"
Case "j"
taiiku = "(柔)"
Case "i"
taiiku = "(情)"
End Select
' classonly = Left(classonly, nagasa - 1)

End If
' gakunenmoji = Left(nenkumi, 1)
' If IsNumeric(gakunenmoji) = False Then
' If nenkumi = "HR" Then

If IsNumeric(Left(nenkumi, 1)) = True Then

gakunenmoji = Left(nenkumi, 1)
gakunen = Val(gakunenmoji)

classonly = Mid(nenkumi, 2)
nagasa = Len(classonly)

If UCase(Right(classonly, 1)) <> Right(classonly, 1) Then
' classsentakuonly = Left(classonly, nagasa - 1)
nagasa = nagasa - 1
' Select Case Right(classonly, 1)
' Case "s"
' taiiku = "(水)"
' Case "h"
' taiiku = "(保)"
' Case "j"
' taiiku = "(柔)"
' End Select
classonly = Left(classonly, nagasa)
Else
taiiku = ""
End If

' If nagasa = 1 Then
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
' t = j - 1
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' MsgBox s & t & namae
' Worksheets("全組").Cells(s, t) = namae
' Else

jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
t = j - 1

For pp = 1 To nagasa

tanclass = Mid(classonly, pp, 1)
nenkumitanclass = gakunenmoji & tanclass
Set myobj = myrange.Find(nenkumitanclass)

s = myobj.Row
Worksheets("全組").Cells(s, t) = namae & taiiku
Next
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
' t = j - 1
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' Worksheets("全組").Cells(s, t) = namae & taiiku
' Else
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = "選択" & Worksheets("全担当者").Cells(i, 1).MergeArea(1, 1).Value
' t = j - 1

' For p = 1 To nagasa

' tanclass = Mid(classsentakuonly, p, 1)
' nenkumi = gakunenmoji & tanclass
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' Worksheets("全組").Cells(s, t) = namae & taiiku
' Next

End If
Next
Else
namae = "教科間選択"
t = j - 1
For p = 1 To n
If IsNumeric(Left(nenkumi, 1)) = True Then

gakunenmoji = Left(nenkumi, 1)
gakunen = Val(gakunenmoji)

classonly = Mid(nenkumi, 2)
nagasa = Len(classonly)

If UCase(Right(classonly, 1)) <> Right(classonly, 1) Then
' classsentakuonly = Left(classonly, nagasa - 1)
nagasa = nagasa - 1
' Select Case Right(classonly, 1)
' Case "s"
' taiiku = "(水)"
' Case "h"
' taiiku = "(保)"
' Case "j"
' taiiku = "(柔)"
' End Select
classonly = Left(classonly, nagasa)
' Else
' taiiku = ""

End If

' If nagasa = 1 Then
' jigen = Worksheets("全担当者").Cells(1, j).Value
' namae = Worksheets("全担当者").Cells(i, 2).Value
' t = j - 1
' Set myobj = myrange.Find(nenkumi)

' s = myobj.Row
' MsgBox s & t & namae
' Worksheets("全組").Cells(s, t) = namae
' Else

For i = 2 To tantoushanokazu + 1
For j = 3 To 41
iro = Cells(i, j).Value
If iro = "HR" Or iro = "*" Or iro = "＊" Or iro = "HS" Then
Select Case iro
Case "HR"
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iroHR(1), iroHR(2), iroHR(3))
Case "HS"
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iroHS(1), iroHS(2), iroHS(3))
Case "*"
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iropink(1), iropink(2), iropink(3))
Case "＊"
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iropink(1), iropink(2), iropink(3))
End Select
ElseIf iro <> "" Then
irogakunen = Val(Left(iro, 1))
Select Case irogakunen
Case 1
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro1(1), iro1(2), iro1(3))
Case 2
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro2(1), iro2(2), iro2(3))
Case 3
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro3(1), iro3(2), iro3(3))
Case 4
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro4(1), iro4(2), iro4(3))
Case 5
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro5(1), iro5(2), iro5(3))
Case 6
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iro6(1), iro6(2), iro6(3))
Case Else
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(irokaigi(1), irokaigi(2), irokaigi(3))

End Select
Else
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(255, 255, 255)

End If
Next
Next

Worksheets("全組").Select

For i = 1 To classnokazu + 1
For j = 1 To 40
iro = Cells(i, j).Value

If iro = "HR" Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iroHR(1), iroHR(2), iroHR(3))
ElseIf iro = "" Then

Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iropink(1), iropink(2), iropink(3))

ElseIf InStr(iro, "(水)") <> 0 Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iros(1), iros(2), iros(3))
ElseIf InStr(iro, "(保)") <> 0 Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iroh(1), iroh(2), iroh(3))
ElseIf InStr(iro, "(柔)") <> 0 Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(iroj(1), iroj(2), iroj(3))
ElseIf InStr(iro, "選択") <> 0 Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(irosen(1), irosen(2), irosen(3))
If iro = "教科間選択" Then
Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(irokyoukakan(1), irokyoukakan(2), irokyoukakan(3))
End If
Else

Range(Cells(i, j), Cells(i, j)).Interior.Color = RGB(255, 255, 255)
End If

Next
Next
Range("A1").Interior.Color = RGB(255, 255, 255)

End Sub

時間割マクロ完成

いいなと思ったら応援しよう！