数学の部屋へもどるエクセルのマクロで解きました。
Option Explicit
Const R = 1
Const C = 9
Sub Macro1()
Sheets("Sheet1").Select
Cells(R, C).Value = 0
Range("A1").Select
Dim a(10) As Integer
Call saiki(1, a())
Call mondai4(0)
Range("A1").Select
MsgBox "終了しました．", vbOKOnly
End Sub
Sub saiki(ByVal n As Integer, ByRef a() As Integer)
Dim a_max As Integer
Dim j As Integer
a(n) = 0
j = 1
While a(n) < 1 And j < n
If a(j) = 0 Then
a(n) = 1
Else
j = j + 1
End If
Wend
Select Case n
Case 1
a_max = 1
Case 2
If a(1) = 0 Then
a_max = 9
Else
a_max = 2
End If
Case 3
If a(1) * 10 + a(2) = 2 Then
a_max = 2
Else
a_max = 3
End If
Case 4
Select Case a(1) * 10 + a(2)
Case 2
a_max = 9
Case 4, 6, 9, 11
If a(3) = 3 Then
a_max = 0
Else
a_max = 9
End If
Case Else
If a(3) = 3 Then
a_max = 1
Else
a_max = 9
End If
End Select
Case 5
a_max = 2
Case 6
If a(5) = 2 Then
a_max = 3
Else
a_max = 9
End If
Case 7, 9
a_max = 5
Case Else
a_max = 9
End Select
'
While a(n) <= a_max
If dame(n, a()) = 0 Then
If n < 9 Then
Call saiki(n + 1, a())
Else
a(10) = 0
For j = 1 To 9
a(10) = a(10) + j - a(j)
Next j
If dame(10, a()) = 0 Then
Cells(R, C).Value = Cells(R, C).Value + 1
For j = 1 To 5
Cells(Cells(R, C).Value, j + C).Value = a(j * 2 - 1) * 10 + a(j * 2)
Next j
If Cells(R, C).Value = 1 Then
Call mondai12(1, a())
End If
Call mondai12(2, a())
If Cells(R, C).Value > 1 Then
Call mondai3(0)
End If
End If
End If
End If
a(n) = a(n) + 1
Wend
End Sub
Sub mondai12(ByVal mondai As Integer, ByRef a() As Integer)
Dim gyou As Integer
Dim j As Integer
gyou = mondai * 2 - 1
Cells(gyou, 1).Value = mondai
For j = 1 To 5
Cells(gyou, j + 2).Value = a(j * 2 - 1) * 10 + a(j * 2)
Next j
End Sub
Sub mondai3(ByVal p As Integer)
Dim s As Long
Dim b(1, 5) As Integer
Dim gyou As Integer
Dim j1 As Integer
Dim j2 As Integer
Dim j3 As Integer
Cells(5, 1).Value = 3
gyou = Cells(R, C).Value
For j1 = 1 To 5
For j2 = 0 To 1
b(j2, j1) = Cells(gyou - (1 - j2), j1 + C).Value
Next j2
Next j1
s = sa(b())
If Cells(R, C).Value = 2 Then
Cells(5, 2).Value = s
Cells(6, 2).Value = 1
For j1 = 1 To 5
For j2 = 0 To 1
Cells(5 + j2, j1 + 2).Value = b(j2, j1)
Next j2
Next j1
ElseIf Cells(5, 2).Value > s Then
For j1 = 1 To Cells(6, 2).Value
For j2 = 3 To 7
For j3 = 0 To 1
Cells(5 + (j1 - 1) * 2 + j3, j2).Value = ""
Next j3
Next j2
Next j1
Cells(5, 2).Value = s
Cells(6, 2).Value = 1
For j1 = 1 To 5
For j2 = 0 To 1
Cells(5 + j2, j1 + 2).Value = b(j2, j1)
Next j2
Next j1
ElseIf Cells(5, 2).Value = s Then
Cells(6, 2).Value = Cells(6, 2).Value + 1
For j1 = 1 To 5
For j2 = 0 To 1
Cells(5 + j2 + (Cells(6, 2).Value - 1) * 2, j1 + 2).Value = b(j2, j1)
Next j2
Next j1
End If
End Sub
Sub mondai4(ByVal p As Integer)
Dim b(1, 5) As Integer
Dim s As Long
Dim ss As String
Dim gyou As Integer
Dim j1 As Integer
Dim j2 As Integer
Dim j3 As Integer
Dim j4 As Integer
gyou = Cells(6, 2).Value * 2 + 6
Cells(gyou, 1).Value = 4
Range("A" & gyou).Select
For j1 = 1 To Cells(R, C).Value - 1
For j2 = 1 To 5
For j3 = 0 To 1
b(j3, j2) = Cells((gyou + j1 - 1) + j3, j2 + C).Value
Next j3
Next j2
s = sa(b())
If j1 = 1 Then
Cells(gyou, 2).Value = s
Cells(gyou + 1, 2).Value = 1
For j2 = 1 To 5
For j3 = 0 To 1
Cells(gyou + j3, j2 + 2).Value = b(j3, j2)
Next j3
Next j2
ElseIf Cells(gyou, 2).Value < s Then
For j2 = 1 To Cells(gyou + 1, 2).Value
For j3 = 3 To 7
For j4 = 0 To 1
Cells(gyou + (j2 - 1) * 2 + j4, j3).Value = ""
Next j4
Next j3
Next j2
Cells(gyou, 2).Value = s
Cells(gyou + 1, 2).Value = 1
For j2 = 1 To 5
For j3 = 0 To 1
Cells(gyou + j3, j2 + 2).Value = b(j3, j2)
Next j3
Next j2
ElseIf Cells(gyou, 2).Value = s Then
Cells(gyou + 1, 2).Value = Cells(gyou + 1, 2).Value + 1
For j2 = 1 To 5
For j3 = 0 To 1
Cells(gyou + j3 + (Cells(gyou + 1, 2).Value - 1) * 2, j2 + 2).Value = b(j3, j2)
Next j3
Next j2
End If
Next j1
s = Cells(gyou, 2).Value
ss = Str(s Mod 60) + "秒"
s = s \ 60
ss = Str(s Mod 60) + "分" + ss
s = s \ 60
ss = Str(s \ 24) + "日" + Str(s Mod 24) + "時間" + ss
Cells(gyou + 2, 1).Value = ss
End Sub
Private Function dame(ByVal n As Integer, ByRef a() As Integer) As Integer
Dim j As Integer
dame = 0
j = 1
While dame = 0 And j < n
If a(j) = a(n) Then
dame = 1
Else
j = j + 1
End If
Wend
End Function
Private Function days(ByVal month As Integer) As Integer
Select Case month
Case 2
days = 29
Case 4, 6, 9, 11
days = 30
Case Else
days = 31
End Select
End Function
Private Function days2(ByVal month As Integer, ByVal day As Integer) As Integer
Dim j As Integer
days2 = day
For j = 1 To month - 1
days2 = days2 + days(j)
Next j
End Function
Private Function sa(ByRef b() As Integer) As Long
Dim s(4) As Integer
Dim j As Integer
s(1) = days2(b(1, 1), b(1, 2)) - days2(b(0, 1), b(0, 2))
For j = 2 To 4
s(j) = b(1, j + 1) - b(0, j + 1)
Next j
For j = 4 To 2 Step -1
If s(j) < 0 Then
s(j - 1) = s(j - 1) - 1
s(j) = s(j) - 60 * (j > 2) - 24 * (j = 2)
End If
Next j
sa = s(1)
For j = 2 To 4
sa = sa * (-24 * (j = 2) - 60 * (j > 2)) + s(j)
Next j
End Function
◆ 問題へもどる
◆ 今週の問題へ