VBAパズル解析～覆面算に挑戦『時間の足し算 ⏳』

『覆面算』とは、記号で表された数式の空欄に、0～9の数字を当てはめて完成させるパズルです。推理しながら正しい計算式を導きます。

大事なルール：違うアルファベットには違う数字、同じアルファベットには同じ数字を入れる。

「ＨＯＵＲ＋ＭＩＮ＝ＴＩＭＥ」は、９種類のアルファベット {E, H, I, M, N, O, R, T, U} で構成された英文です。これらのアルファベットに、便宜上インデックス（番号）を割り振ります。ただし、ここで付ける番号はアルファベットに対応する数値ではなく、識別のためのインデックスです。混同を避けるため、インデックスは括弧書きで表記します。

こういうことです。

次の等式が成立するものを力技で探します。

　  (2)×1000 ＋ (6)×100 ＋ (9)×10 ＋ (7)×1
＋               (4)×100 ＋ (3)×10 ＋ (5)×1
＝  (8)×1000 ＋ (2)×100 ＋ (4)×10 ＋ (1)×1

① VBAのModule1に次のコードを記載します。

Option Explicit

Public Sub HourMinTime()

    ' タイトル
    Const TITLE As String = "Hour Min Time"

    ' 単純なループカウンタ
    Dim lp1 As Long, lp2 As Long
    
    Const P As Long = 10      ' 要素数
    Const n As Long = 9       ' 選択できる数

    ' 答えの数をカウントする変数
    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)

    ' 連想配列を作成する。
    Dim hs As Object
    Set hs = CreateObject("Scripting.Dictionary")
    hs.Add 1, 1
    hs.Add 2, 2
    hs.Add 3, 3
    hs.Add 4, 4
    hs.Add 5, 5
    hs.Add 6, 6
    hs.Add 7, 7
    hs.Add 8, 8
    hs.Add 9, 9
    hs.Add 10, 0  ' ※１０→０

    ' 作成した順列の内容を書き換える。
    For lp1 = 1 To UBound(permArray, 1)
        For lp2 = 1 To UBound(permArray, 2)
    
            ' 連想配列を使って書き換える。
            permArray(lp1, lp2) _
                = hs.Item(permArray(lp1, lp2))
        
        Next lp2
    Next lp1

    ' 作った配列を一つずつ検証する。
    For lp1 = 1 To UBound(permArray, 1)
        
        ' 作業用配列を作る。
        Dim wk() As Long
        ReDim wk(UBound(permArray, 2)) As Long
        
        For lp2 = 1 To UBound(permArray, 2)
            wk(lp2) = permArray(lp1, lp2)
        Next lp2
        
        ' "時"を作る。
        Dim h As Long
        h = wk(2) * 1000 _
            + wk(6) * 100 _
            + wk(9) * 10 _
            + wk(7)
        
        ' "分"を作る。
        Dim m As Long
        m = wk(4) * 100 _
            + wk(3) * 10 _
            + wk(5)
        
        ' "時刻"を作る。
        Dim tm As Long
        tm = wk(8) * 1000 _
            + wk(3) * 100 _
            + wk(4) * 10 _
            + wk(1)
        
        ' 条件Aを検証する。
        If h + m = tm Then

            ' 見つかった答えを書き出す。
            With Range("A1")
                .Cells(ansCnt * 4 + 1, 2).Value = wk(2)
                .Cells(ansCnt * 4 + 1, 3).Value = wk(6)
                .Cells(ansCnt * 4 + 1, 4).Value = wk(9)
                .Cells(ansCnt * 4 + 1, 5).Value = wk(7)
                .Cells(ansCnt * 4 + 2, 1).Value = "＋"
                .Cells(ansCnt * 4 + 2, 3).Value = wk(4)
                .Cells(ansCnt * 4 + 2, 4).Value = wk(3)
                .Cells(ansCnt * 4 + 2, 5).Value = wk(5)
                .Cells(ansCnt * 4 + 3, 2).Value = wk(8)
                .Cells(ansCnt * 4 + 3, 3).Value = wk(3)
                .Cells(ansCnt * 4 + 3, 4).Value = wk(4)
                .Cells(ansCnt * 4 + 3, 5).Value = wk(1)
            End With

            ' 枠線の描画を行う。
            Range("A1:E1").Offset(ansCnt * 4 + 1, 0) _
                .Borders(xlEdgeBottom).LineStyle = xlContinuous

            ' 答えの数をカウントする。
            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

    ' オブジェクトを解放する。
    Set hs = Nothing

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

② Sheet1を開いた状態で「HourMinTime()」を動かしてみましょう。