次の分数式の８つのマス目に、１～８の異なる数字を入れて数式を成立させてください。このようなパズルは『数入れパズル』と呼ばれます。
なお、分数の値がすべて整数になるとは限りません。むしろ、無理数になる場合のほうが多いでしょう。
単なる勘で答えを見つけるのは難しく、論理的に考える必要があるパズルです。
次の等式が成立するものを探します。
数式のマス目に番号を付けます。
※ここで付ける番号は、マス目に入れる数字ではなく、マス目の番地を表す便宜上のインデックスです。このインデックスと、マス目に入れる数字とを区別するために、括弧書きで番地を表現することにします。
以下の条件を満たす数字を探します。
(1)÷(2) － (3)÷(4) － (5)÷(6) ＝ (7)÷(8)しかし、VBAでの割り算は誤差を含む点に注意が必要です。
以下のページで小数点以下を含む数値計算における誤差を紹介していますので参考に。
割り算を用いない方法を選ぶことにします。
※これを考慮しないと、答えのパターンのいくつかを見つけられなくなるので必須です！！ご注意を！！
(1)÷(2) － (3)÷(4) － (5)÷(6) ＝ (7)÷(8)
→ (1)×(4)×(6)×(8) － (3)×(2)×(6)×(8) － (5)×(2)×(4)×(8) ＝ (7)×(2)×(4)×(6)
① 次のプログラムをModule1に記載します。
Option Explicit
Public Sub NumericalFormula()
' タイトル
Const TITLE As String = "Numerical Formula"
' 単純なループカウンタ
Dim lp1 As Long, lp2 As Long
Const P As Long = 8 ' 要素数
Const N As Long = 8 ' 選択できる数
' 答えの数をカウントする変数
Dim ansCnt As Long
' パズルの解析を始めるか問い合わせる。
Dim ret
ret = MsgBox( _
"パズルの解析を始めますか？" _
, vbYesNo + vbQuestion _
, TITLE _
)
' [No]の場合は処理を継続しない。
If ret = vbNo Then
Exit Sub
End If
' １～８の中から８個の数字を使った順列を作成する。
Dim permArray() As Integer
permArray = makePermutation(P, N)
' 作った配列を一つずつ検証する。
For lp1 = 1 To UBound(permArray, 1)
' 作業用配列を作る。
Dim wk() As Integer
ReDim wk(UBound(permArray, 2)) As Integer
For lp2 = 1 To UBound(permArray, 2)
wk(lp2) = permArray(lp1, lp2)
Next lp2
' 左辺と右辺を作る。
Dim left1 As Double
Dim left2 As Double
Dim left3 As Double
Dim right As Double
left1 = wk(1) * wk(4) * wk(6) * wk(8)
left2 = wk(3) * wk(2) * wk(6) * wk(8)
left3 = wk(5) * wk(2) * wk(4) * wk(8)
right = wk(7) * wk(2) * wk(4) * wk(6)
' 左辺と右辺の値を比較する。
If left1 - left2 - left3 = right Then
' 見つかった答えを書き出す。
With Range("A1")
.Cells(ansCnt + 1, 1).Value = wk(1)
.Cells(ansCnt + 1, 2).Value = wk(2)
.Cells(ansCnt + 1, 3).Value = wk(3)
.Cells(ansCnt + 1, 4).Value = wk(4)
.Cells(ansCnt + 1, 5).Value = wk(5)
.Cells(ansCnt + 1, 6).Value = wk(6)
.Cells(ansCnt + 1, 7).Value = wk(7)
.Cells(ansCnt + 1, 8).Value = wk(8)
End With
' 答えの数をカウントする。
ansCnt = ansCnt + 1
End If
' メモリを解放する。
Erase wk
Next lp1
' 答えが見つかったかどうか判別する。
If ansCnt = 0 Then
MsgBox "答えは見つかりませんでした。" _
, vbExclamation _
, TITLE
Else
MsgBox "答えは" & ansCnt & "件見つかりました。" _
, vbInformation _
, TITLE
End If
' メモリを解放する。
Erase permArray
End Sub
'
' 順列作成関数
'
Public Function makePermutation( _
N As Long _
, r As Long _
) As Integer()
' 単純なループカウンタ
Dim lp1 As Long, lp2 As Long, lp3 As Long, lp4 As Long
' 順列数特定用変数
Dim caseCnt As Long
' 戻り値作成用変数
Dim ret() As Integer
' 順列数を特定する。
caseCnt = 1
For lp1 = N To (N - r + 1) Step -1
caseCnt = caseCnt * lp1
Next lp1
' 戻り値配列を作成する。
ReDim ret(caseCnt, r) As Integer
' 作成済みの順列の数を保持する変数
Dim pos As Long
pos = 1
' 作成中の順列の数を保持する変数
Dim wkPos As Long
wkPos = 1
' 順列の最初の一つを作成する。
For lp1 = 1 To r
ret(pos, lp1) = lp1
Next lp1
' 二番目に大きな値から順に処理する。
For lp1 = N - 1 To 1 Step -1
' "一つ大きな値"～"一番大きな値"まで順に処理する。
For lp2 = lp1 + 1 To N
' 作成済みの順列を一つずつ処理する。
For lp3 = 1 To pos
' 作成中の順列の数を一つ増やす。
wkPos = wkPos + 1
' 一度でも入れ替え処理を行ったか判別するための
' フラグをFalseで初期化する。
Dim flg As Boolean
flg = False
' lp2とlp1が指す値の入れ替え処理を行う。
For lp4 = 1 To r
If ret(lp3, lp4) = lp1 Then
ret(wkPos, lp4) = lp2
flg = True
ElseIf ret(lp3, lp4) = lp2 Then
ret(wkPos, lp4) = lp1
flg = True
Else
ret(wkPos, lp4) = ret(lp3, lp4)
End If
Next lp4
' 一度でも入れ替え処理を行ったか判別する。
If flg = False Then
' 今作った順列を削除する。
wkPos = wkPos - 1
End If
Next lp3
Next lp2
' 作成済みの順列の数を更新する。
pos = wkPos
Next lp1
' 作成した順列を呼び出し元に返す。
makePermutation = ret
End Function
⑤ NumericalFormula() を実行します。
結果が得られます。
１２件が見つかりました！
コメントを残す