VBAで「3Lと5Lのバケツで4Lの水を作る」を解く

公開日：2020-08-24　最終更新日：2020-12-20

VBAで「3Lと5Lのバケツで4Lの水を作る」を解く

ツイッターでVBAのお題として出したものです。

昔からよくある問題です。
「3Lと5Lのバケツで4Lの水を作る」
これをVBAを使って自動で求めてみようという事です。

VBA問題：ツイートの記録

【VBA問題】
「3Lと5Lのバケツで4Lの水を作る」
・2つの容器サイズは変えられるように引数で受け取る
　（3,5,4、3,7,5）
・最短手順を出力（複数ある場合は複数）
※ルール
容器は、
・満タンにする
・空にする
・相手が満タンになるまで注ぐ
以上の操作のみ、
この最短手順を示してください。

https://twitter.com/yamaoka_ss/status/1297260976333443073

応募お待ちしてます。
難しいですかね、難しいよね、でも頑張ればできますよね、頑張ってやってみましょう。
ひとまず最短手順というのは後回しでも良いです。
バケツは2つ、それぞれ出来る動作は3つ、つまり6通り。
これを繰り返して、どちらかのバケツが4Lになれば良いだけです。

https://twitter.com/yamaoka_ss/status/1297380147566264322

応募が無いのでアンケートを取ってみました

応募は来ますかね。
確かに結構難しいですよね。
では、聞いて見ましょう
このアンケートの締め切りは、今夜22時

https://twitter.com/yamaoka_ss/status/1297419663551262720

何名かは応募するから待ってとありましたが、過半数の人から「解説しろ」と言われてしまいました。
ということで、以下のように連続ツイートで、解き方考え方、そしてVBA実装方法について説明しました。

回答をいただきました。

VBA VBAノック番外編その２

harigami タイトルなし

解き方考え方、そしてVBA実装方法：連ツイによる説明

説明ツイートの原文は、問題を出したツイートから辿ってください。
以下は、ほぼ原文のままですが一部補正しています。

では説明を考えながら、ゆっくりとツイートしていきます。
まず、このような問題は恐らく相応のアルゴリズムがあり、そのような勉強をしている人は○○探索だろ、みたいなものがるのだろうと思います。
残念ながら私はそのような勉強をしたことが無い、、、
（というか勉強全般しいてないw）

したがって、もっと効率の良い方法や実装方法もあるだろうと思います。
今回に限らず、ゲーム作る時はほぼ毎回そうなのですが、頭の中で考えて持っている知識の範囲で解く方法を考えています。ただし、もちろんその過程で困った時は一部はググって解決します。

今回のVBAも完全独自の今回0から考えたものなので、非効率な部分があるのはご容赦ください。
教科書的な解法を知りたい人は、書籍を探して読んでください。
ただし、大筋では似たようなことをしているのではないかと思います。

2つのバケツがあり、それぞれに行える動作は3つ
・満タンにする
・空にする
・相手の容器に移す
つまり、ある場面での操作は6通り存在します。
これを全パターン試していたら、とても膨大な数になってしまいます。
1→6→6^2→6^3→・・・
数回の手順で数万に達してしまいます。

数が多いだけならPCに委ねれば何とかなるかもしれません。
しかし、無限に繰り返されるパターンが出てくるとPCでもどうしようもなくなってしまいます。
そこで、大抵のゲームには無限に繰り返されることをどこかで制限するルールが存在します。

将棋なら千日手、囲碁ならコウのようなものです。
今回のバケツの問題も実はこの制限をしっかりかけています。
それは
「最短手順を示してください。」
最後のこの一文になります。
これが無いと、バケツAを満タン→空、これを繰り返すことが意味を持ってしまうので答えが無限に発生してしまいます。

※以下、バケツ2つを、バケツAとバケツBとして表現しています。

この最短手順がとても重要になります。
それは、ある場面での操作の結果が以前の状態と同じ状態になる操作は意味を為さないという事です。
例えば、
A3L,B5Lとなった場合、次の操作はA3L,B0LまたはA0L,B5Lにしかなりません。
これは最初の操作でどちらかのバケツを満タンにした状態と同じです。

そして過去の状態と同一になった時点で最短手順ではなくなるので、
それ以降の探索は意味がなくなるので打ち切っても良いという事です。
さらに、3つの操作のうち無効な操作が常に存在します。
Aが満タンの時には、
・Aを満タン
・B→A
少なくともこの2つの操作は無効になります。

バケツAとバケツBの状態によって、行える操作は意外に少ないのです。
決して1→6→6^2とは増えていきません。
ある場面の次の状態は大体2～3通りしか存在しません。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
この2点をしっかりプログラミングすれば良いという事です。

言葉では伝わりづらいと思うので、簡単に図を書きました。
この図では、無効な操作および過去に戻ってしまう操作を消しています。
レベル2の(3,5)は先に説明したように(0,5)(3,0)のどちらかになるのでレベル1に戻ってしまいます。
したがってここで終了となっています。
※太線は答えのルートです。

これを見て分かるように、実際に行える操作はとても少ないです。
2つのバケツに3通りの操作と考えると途方もなく感じてしまいますが、実際に操作できる数は極めて少ないです。
ただし人間が頭の中で考えた時はそんなにスムーズにいきません。
過去に存在した状態を全て記憶していられないからです。

人間は多くの事を記憶したり膨大な数をこなすことは苦手です。
しかしコンピューターはそれが得意です。
というか、むしろそれしか出来ないと言っても良いと思いますが、、、
再度書きます。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
これをVBAで書けばよいのです。

では、VBA実装の具体例（今回私が書いたVBA）について、簡単に説明していきます。
まず、「バケツ」クラスを作成しました。
ルールの範囲内に限定したプロパティ・メソッドのみ作成しました。
したがって間違って設定させたくないプロパティは読み取り専用プロパティにしています。

Function Create … コンストラクタとして使用
Property Get Name
Property Get MaxValue
Property Get Value
Function Full
Function Emptied … Emptyは予約語
Function Transfer
Sub Receive … Transferで貰う時
※Name,MaxValue,Valueは読み取り専用、他のメソッドで設定

CreateはMeを返します。
Full,Emptied,Transferの戻り型はBooleanです。
操作が有効な場合True/無効な場合False
つまり3つの操作でFalseが返ってきた場合は無効なので打ち切ります。
これで、
・行える操作をしっかり限定する
これが完成です。

続いて、
・過去と同じになったらそのルートは終了
このためには、状態の保存が必要です。
先に出した以下の図、これをそのまま配列として持ちます。
縦のレベルを1次元配列として作り、その各要素の中に横に展開されている複数状態を配列として入れます。
いわゆるジャグ配列です。

ここは手法がいろいろありそうです。
単純な1次元だけで展開し、チェーンのようなものを付けていくと言った方法も使われたりするかもしれません。
今回の場合は「最短手順」がキーとなっているので、縦がそのまま手順回数になるので都合が良かったのでこのようにしてみました。

問題はこの各要素の中にどのような情報を入れるかになります。
答えにたどり着いたとき、ルート（操作手順）が分かるようにしておかなければなりません。
この時にも、実装方法は大きく分かれると思います。
・開始からのルート情報を入れておく
・親を示すポインタを入れておく

今回私は後者のポインタ方式にしました。
VBAのコード量としては、前者の方が短くて済んだ気がします。
この辺りは、試行回数をどの程度で予測するかによるかもしれません。
何よりその時の気分で決めたしまったというのが本当のところです。

ただし親のポインタといっても、親を探しやすいように、親の位置はしっかりわかるように複数情報を入れました。
実際には使っていない情報も含めて配列に格納しています。
親の情報と自身の情報を目いっぱい入れました。
メモリや処理速度を気にするようなものではないことは分っている事でしたので。

配列に入れた情報は以下です。
・自身ユニーク番号
・親のユニーク番号
・親のレベル内での位置
・自身のレベル
・自身のレベル内での位置
・自身の名前
・実行メソッド
・移す場合の相手の名前
・自身の最大容量
・相手の最大容量
・自身の水量
・相手の水量

この配列にいれる多値はクラスにしました。
やはり、こういう時はユーザー定義型は使えないですね。
以上で準備は完了です。
メインとなるプロシージャーで、2つのバケツに対して3通りのメソッドを答えにたどり着くまで繰り返していきます。

最初にレベル0として、両方が空の状態で配列を作成します。
その後は、レベル内（親のレベル）の配列を順次取り出し、
取り出した情報でバケツ2つを再作成して、3つのメソッドをそれぞれに実行します。
有効なメソッドは順次レベル+1の配列に入れていきます。

親のレベル内の配列全ての処理が終了したら答えがあるかを確認し、答えがあったら、ルートを逆に辿って文字列の配列で返します。
答えが無ければ、レベルを+1してループします。
一応、同一レベルに複数解があれば出るはずなのですが、そのような数値の組み合わせがあるのかどうか分かりません。

以上で説明を終わります。長々とお付き合いくださり感謝申し上げます。
この連ツイと共に、VBAソースコードは明日記事として公開する予定でいます。

作成したVBAの全コード

「バケツ」クラス

オブジェクト名：clsBucket


  
    
      Option Explicit


Private Name_ As String

Private MaxValue_ As Long

Private Value_ As Long


'**********************************************************************

' コンストラクタとして使用：名前と容量はここでのみ設定

'**********************************************************************


Public Function Create(ByVal argName As String, _

　　　　　　　　　　　 ByVal argMaxValue As Long, _

　　　　　　　　　　　 ByVal argValue) As clsBucket

　　Name_ = argName

　　MaxValue_ = argMaxValue

　　Value_ = argValue

　　Set Create = Me

End Function


'**********************************************************************

' 公開プロパティ：VBA記述を明確にするためにクラス内では使用しない

'**********************************************************************


Public Property Get Name() As String

　　Name = Name_

End Property


Public Property Get MaxValue() As Long

　　MaxValue = MaxValue_

End Property


Public Property Get Value() As Long

　　Value = Value_

End Property


'**********************************************************************

' 公開メソッド：満タン、空にする、相手に移す

'**********************************************************************


Public Function Full() As Boolean

　　If Value_ <> 0 Then

　　　　Full = False

　　Else

　　　　Value_ = MaxValue_

　　　　Full = True

　　End If

End Function


Public Function Emptied() As Boolean

　　If Value_ = 0 Then

　　　　Emptied = False

　　Else

　　　　Value_ = 0

　　　　Emptied = True

　　End If

End Function


Public Function Transfer(ByVal argObj As clsBucket) As Boolean

　　Transfer = False

　　

　　Dim trnsValue As Long

　　'相手の空き容量

　　trnsValue = argObj.MaxValue - argObj.Value

　　If trnsValue = 0 Then

　　　　Transfer = False

　　End If

　　

　　'持っている量しか移せない

　　If Value_ = 0 Then

　　　　Exit Function

　　End If

　　If trnsValue > Value_ Then

　　　　trnsValue = Value_

　　End If

　　

　　Call argObj.Receive(trnsValue)

　　Value_ = Value_ - trnsValue

　　

　　Transfer = True

End Function


Public Sub Receive(ByVal argValue As Long)

　　Value_ = Value_ + argValue

      End Sub

「配列格納情報」クラス

オブジェクト名：clsManage


  
    
      Option Explicit


'親の情報

Public ParentNo As Long

Public ParentIndex As Long


'自身の情報

Public No As Long

Public Level As Long

Public IndexInLevel As Long

Public OpeObject As String

Public OpeMethod As String

Public OpeTarget As String


'Aが自身、Bが相手

Public A_MaxValue As Long

Public B_MaxValue As Long

Public A_Value As Long

Public B_Value As Long

標準モジュール


  
    
      '**********************************************************************

' 結果をイミディエイトに見やすいように出力

'**********************************************************************


      Public Sub PrintProcedure(ByVal A As Long, _

　　　　　　　　　　　　　ByVal B As Long, _

　　　　　　　　　　　　　ByVal C As Long)

　　Dim ans, v1, v2, cnt

　　

　　ans = ShortestProcedure(A, B, C)

　　Debug.Print vbLf & "■A=" & A & ",B=" & B & " → " & C

　　

　　If IsEmpty(ans) Then

      　　　　Debug.Print "答えを見つけられませんでした。"

　　　　Exit Sub

　　End If

　　

　　cnt = 1

　　For Each v1 In ans

　　　　Debug.Print "手順" & cnt

　　　　For Each v2 In v1

　　　　　　Debug.Print v2

　　　　Next

　　Next

End Sub


'**********************************************************************

' バケツは引数の順にA,Bとしています。

'**********************************************************************


'容量の違う2つのバケツから指定容量を作り出す

      Public Function ShortestProcedure(ByVal A As Long, _

　　　　　　　　　　　　　　　　　ByVal B As Long, _

　　　　　　　　　　　　　　　　　ByVal C As Long) As Variant

　　Dim AryStatus 'ジャグ配列

　　Dim ParentAry() As clsManage

　　Dim CurAry() As clsManage

　　

　　Dim cntNo As Long '全体件数、ユニーク番号

　　Dim CurLevel As Long '現在処理中のレベル

　　Dim IndexInLevel As Long '同一レベル内の件数

　　cntNo = 0

　　CurLevel = 0

　　

　　Dim BucketA As New clsBucket

　　Dim BucketB As New clsBucket

　　

　　'以降と統一する為にジャグ配列にする

　　ReDim CurAry(0)

　　Set CurAry(0) = CreateStatus(cntNo, 0, 0, CurLevel, 0, "", "", "", _

　　　　　　　　　　　　　　　　 BucketA.Create("A", A, 0), _

　　　　　　　　　　　　　　　　 BucketB.Create("B", B, 0))

　　ReDim AryStatus(CurLevel)

　　AryStatus(CurLevel) = CurAry

　　

      　　'目的の数値になるまで繰り返す。

　　Dim i As Long

　　Do

　　　　'親レベルの配列を取り出す

　　　　ParentAry = AryStatus(CurLevel)

　　　　

　　　　'現在レベルの配列の用意

　　　　CurLevel = CurLevel + 1

　　　　ReDim Preserve AryStatus(CurLevel)

　　　　IndexInLevel = 0 '同一レベル内の件数

　　　　

　　　　'親レベルの配列をループ

　　　　ReDim CurAry(0)

　　　　For i = LBound(ParentAry) To UBound(ParentAry)

　　　　　　'Aバケツのメソッド3種類を全てトライしてみる

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Full")

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Emptied")

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "A", "Transfer")

　　　　　　'Bバケツのメソッド3種類を全てトライしてみる

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Full")

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Emptied")

　　　　　　Call TryStatus(AryStatus, ParentAry(i), CurAry, IndexInLevel, cntNo, CurLevel, "B", "Transfer")

　　　　Next

　　　　AryStatus(CurLevel) = CurAry

　　　　

　　　　'親レベルから次に進めなかった場合は解なし

　　　　If CurAry(0) Is Nothing Then Exit Function

　　　　

　　　　'目的の数値があればループを抜ける

　　　　If AryExist(AryStatus, C) Then Exit Do

　　　　

　　　　'念の為100レベルで終了

　　　　If CurLevel > 100 Then Exit Function

　　　　

　　　　DoEvents '万一の時に止めやすいように

　　Loop

　　

　　'目的の数値に到達する手順の文字列作成

　　ShortestProcedure = AnswerProcedure(AryStatus, C)

End Function


'指定バケツの指定メソッドを実行し、結果が有効な状態なら配列に追加

Private Sub TryStatus(ByRef AryStatus, _

　　　　　　　　　　　ByVal argParent As clsManage, _

　　　　　　　　　　　ByRef CurAry() As clsManage, _

　　　　　　　　　　　ByRef IndexInLevel As Long, _

　　　　　　　　　　　ByRef cntNo As Long, _

　　　　　　　　　　　ByVal argLevel As Long, _

　　　　　　　　　　　ByVal argAB As String, _

　　　　　　　　　　　ByVal argOpe As String)

　　Dim BucketA As New clsBucket

　　Dim BucketB As New clsBucket

　　Set BucketA = BucketA.Create("A", argParent.A_MaxValue, argParent.A_Value)

　　Set BucketB = BucketB.Create("B", argParent.B_MaxValue, argParent.B_Value)

　　

　　'操作オブジェクトと相手オブジェクトの特定

　　Dim targetObj1 As clsBucket

　　Dim targetObj2 As clsBucket

　　Select Case argAB

　　　　Case BucketA.Name

　　　　　　Set targetObj1 = BucketA

　　　　　　Set targetObj2 = BucketB

　　　　Case BucketB.Name

　　　　　　Set targetObj1 = BucketB

　　　　　　Set targetObj2 = BucketA

　　　　Case Else

　　　　　　Err.Raise Number:=9991, Description:="そんなバケツはない"

　　End Select

　　

　　'メソッド

　　Select Case argOpe

　　　　Case "Full", "Emptied"

　　　　　　If Not CallByName(targetObj1, argOpe, VbMethod) Then Exit Sub

　　　　Case "Transfer"

　　　　　　If Not CallByName(targetObj1, argOpe, VbMethod, targetObj2) Then Exit Sub

　　　　Case Else

　　　　　　Err.Raise Number:=9992, Description:="そんなメソッドはない！"

　　End Select

　　

　　'既に同一状態が存在していたらスキップする

　　If AryExist(AryStatus, BucketA.Value, BucketB.Value) Then Exit Sub

　　

　　'全体件数（ユニークNo）をカウントアップ

　　cntNo = cntNo + 1

　　

　　'保存用の状態を作成

　　Dim tmpStatus As clsManage

　　Set tmpStatus = CreateStatus(cntNo, argParent.No, argParent.IndexInLevel, argLevel, IndexInLevel, targetObj1.Name, argOpe, targetObj2.Name, BucketA, BucketB)

　　

　　'配列に追加する

　　ReDim Preserve CurAry(IndexInLevel) As clsManage

　　Set CurAry(IndexInLevel) = tmpStatus

　　IndexInLevel = IndexInLevel + 1

End Sub


'配列（ジャグ配列と通常配列の両対応）に目的の数値があるか

Private Function AryExist(ByRef argAry, _

　　　　　　　　　　　　　ByVal Avalue As Long, _

　　　　　　　　　　　　　Optional ByVal Bvalue As Long = -1) As Boolean

　　AryExist = True

　　Dim vItem, vChild

　　For Each vItem In argAry

　　　　If Not IsEmpty(vItem) Then

　　　　　　If IsArray(vItem) Then

　　　　　　　　For Each vChild In vItem

　　　　　　　　　　If ValueExist(vChild.A_Value, vChild.B_Value, Avalue, Bvalue) Then

　　　　　　　　　　　　Exit Function

　　　　　　　　　　End If

　　　　　　　　Next

　　　　　　Else

　　　　　　　　If ValueExist(vItem.A_Value, vItem.B_Value, Avalue, Bvalue) Then

　　　　　　　　　　Exit Function

　　　　　　　　End If

　　　　　　End If

　　　　End If

　　Next

　　AryExist = False

End Function


'AB両方の数値確認、または、ある数字の存在確認

Private Function ValueExist(ByVal Avalue1 As Long, _

　　　　　　　　　　　　　　ByVal Bvalue1 As Long, _

　　　　　　　　　　　　　　ByVal Avalue2 As Long, _

　　　　　　　　　　　　　　Optional ByVal Bvalue2 As Long = -1) As Boolean

　　ValueExist = True

　　

　　If Bvalue2 < 0 Then

　　　　If Avalue1 = Avalue2 Or _

　　　　　 Bvalue1 = Avalue2 Then

　　　　　　Exit Function

　　　　End If

　　Else

　　　　If Avalue1 = Avalue2 And _

　　　　　 Bvalue1 = Bvalue2 Then

　　　　　　Exit Function

　　　　End If

　　End If

　　

　　ValueExist = False

End Function


'状態を保存する管理データ作成

Private Function CreateStatus(ByVal aNo As Long, _

　　　　　　　　　　　　　　　ByVal aParentNo As Long, _

　　　　　　　　　　　　　　　ByVal aParentIndex As Long, _

　　　　　　　　　　　　　　　ByVal aLevel As Long, _

　　　　　　　　　　　　　　　ByVal aIndexInLevel As Long, _

　　　　　　　　　　　　　　　ByVal aOpeObject As String, _

　　　　　　　　　　　　　　　ByVal aOpeMethod As String, _

　　　　　　　　　　　　　　　ByVal aOpeTarget As String, _

　　　　　　　　　　　　　　　ByVal aObj1 As clsBucket, _

　　　　　　　　　　　　　　　ByVal aObj2 As clsBucket) As clsManage

　　Set CreateStatus = New clsManage

　　With CreateStatus

　　　　.No = aNo

　　　　.ParentNo = aParentNo

　　　　.ParentIndex = aParentIndex

　　　　.Level = aLevel

　　　　.IndexInLevel = aIndexInLevel

　　　　.OpeObject = aOpeObject

　　　　.OpeMethod = aOpeMethod

　　　　.OpeTarget = aOpeTarget

　　　　.A_Value = aObj1.Value

　　　　.B_Value = aObj2.Value

　　　　.A_MaxValue = aObj1.MaxValue

　　　　.B_MaxValue = aObj2.MaxValue

　　End With

End Function


'**********************************************************************

' 解を見つけた後の回答作成

'**********************************************************************


'状態を保持したジャグ配列から目的の数値を見つけて手順をジャグ配列で戻す

Private Function AnswerProcedure(ByRef AryStatus, _

　　　　　　　　　　　　　　　　 ByVal argValue As Long) As Variant

　　Dim ansAry()

　　Dim cnt As Long

　　Dim vItem, vChild

　　For Each vItem In AryStatus

　　　　If Not IsEmpty(vItem) Then

　　　　　　If IsArray(vItem) Then

　　　　　　　　For Each vChild In vItem

　　　　　　　　　　If ValueExist(vChild.A_Value, vChild.B_Value, argValue) Then

　　　　　　　　　　　　ReDim Preserve ansAry(cnt)

　　　　　　　　　　　　ansAry(cnt) = CreateProcedure(AryStatus, vChild.No, vChild.Level, vChild.IndexInLevel)

　　　　　　　　　　End If

　　　　　　　　Next

　　　　　　End If

　　　　End If

　　Next

　　AnswerProcedure = ansAry

End Function


'指定NOから順に親を辿り手順を配列として作成

Private Function CreateProcedure(ByRef AryStatus, _

　　　　　　　　　　　　　　　　 ByVal aNo As Long, _

　　　　　　　　　　　　　　　　 ByVal aLevel As Long, _

　　　　　　　　　　　　　　　　 ByVal aIndexInLevel As Long) As String()

　　Dim outAry() As String

　　Dim tmpString As String

　　Dim cnt As Long

　　Dim tmpManage As clsManage

　　Do

　　　　Set tmpManage = AryStatus(aLevel)(aIndexInLevel)

　　　　ReDim Preserve outAry(cnt)

　　　　tmpString = tmpManage.OpeObject & "." & _

　　　　　　　　　　tmpManage.OpeMethod & _

　　　　　　　　　　IIf(tmpManage.OpeMethod = "Transfer", "(" & tmpManage.OpeTarget & ")", "")

　　　　tmpString = Replace(tmpString, "Full", "満タン　　")

　　　　tmpString = Replace(tmpString, "Emptied", "空にする　")

　　　　tmpString = Replace(tmpString, "Transfer", "相手に注ぐ")

　　　　tmpString = Left(tmpString & Space(10), 10)

　　　　tmpString = tmpString & " A=" & tmpManage.A_Value & _

　　　　　　　　　　　　　　　　",B=" & tmpManage.B_Value

　　　　outAry(cnt) = tmpString

　　　　

　　　　If tmpManage.ParentNo = 0 Then Exit Do

　　　　

　　　　aNo = tmpManage.ParentNo

　　　　aLevel = aLevel - 1

　　　　aIndexInLevel = tmpManage.ParentIndex

　　　　cnt = cnt + 1

　　　　

　　　　DoEvents '万一の時に止めやすいように

　　Loop

　　

　　'配列を逆転させるDim i As Long

　　Dim ary() As String, i As Long

　　ReDim ary(LBound(outAry) To UBound(outAry))

　　For i = LBound(outAry) To UBound(outAry)

　　　　ary(UBound(outAry) + LBound(outAry) - i) = outAry(i)

　　Next

　　CreateProcedure = ary

End Function

実際のメインとなるプロシージャーは、
ShortestProcedure
これになります。

PrintProcedure
こちらは、あくまでイミディエイトウィンドウにきれいに表示するためのプロシージャーです。

VBAで「3Lと5Lのバケツで4Lの水を作る」を解いた結果


  
    
      Sub 検証テスト()

　　Call PrintProcedure(3, 5, 4)

　　Call PrintProcedure(3, 6, 4)

　　Call PrintProcedure(3, 7, 5)

　　Call PrintProcedure(4, 5, 3)

　　Call PrintProcedure(4, 6, 5)

　　Call PrintProcedure(4, 7, 5)

　　Call PrintProcedure(5, 7, 4)

　　Call PrintProcedure(5, 7, 6)

End Sub

実行結果は、イミディエイトウィンドウに以下のように出力されます。

■A=3,B=5 → 4
手順1
B.満タン　　    A=0,B=5
B.相手に注ぐ(A) A=3,B=2
A.空にする　    A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン　　    A=2,B=5
B.相手に注ぐ(A) A=3,B=4
■A=3,B=6 → 4
答えを見つけられませんでした。
■A=3,B=7 → 5
手順1
B.満タン　　    A=0,B=7
B.相手に注ぐ(A) A=3,B=4
A.空にする　    A=0,B=4
B.相手に注ぐ(A) A=3,B=1
A.空にする　    A=0,B=1
B.相手に注ぐ(A) A=1,B=0
B.満タン　　    A=1,B=7
B.相手に注ぐ(A) A=3,B=5
■A=4,B=5 → 3
手順1
A.満タン　　    A=4,B=0
A.相手に注ぐ(B) A=0,B=4
A.満タン　　    A=4,B=4
A.相手に注ぐ(B) A=3,B=5
■A=4,B=6 → 5
答えを見つけられませんでした。
■A=4,B=7 → 5
手順1
A.満タン　　    A=4,B=0
A.相手に注ぐ(B) A=0,B=4
A.満タン　　    A=4,B=4
A.相手に注ぐ(B) A=1,B=7
B.空にする　    A=1,B=0
A.相手に注ぐ(B) A=0,B=1
A.満タン　　    A=4,B=1
A.相手に注ぐ(B) A=0,B=5
■A=5,B=7 → 4
手順1
B.満タン　　    A=0,B=7
B.相手に注ぐ(A) A=5,B=2
A.空にする　    A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン　　    A=2,B=7
B.相手に注ぐ(A) A=5,B=4
■A=5,B=7 → 6
手順1
B.満タン　　    A=0,B=7
B.相手に注ぐ(A) A=5,B=2
A.空にする　    A=0,B=2
B.相手に注ぐ(A) A=2,B=0
B.満タン　　    A=2,B=7
B.相手に注ぐ(A) A=5,B=4
A.空にする　    A=0,B=4
B.相手に注ぐ(A) A=4,B=0
B.満タン　　    A=4,B=7
B.相手に注ぐ(A) A=5,B=6

同一手順回数で複数の解があれば出るはずなのですが、、、
そういうことは無いのかもしれません、ちょっと無駄な事をしたかもしれない、、、

おまけ：アニメーションさせてみました

もともとお遊びではありますが、
このアニメーションはさらにおまけなので、VBAコードはかなり適当に書いたものになります。
少しでも参考になればと思い、追加で掲載しました。


  
    
      Option Explicit


Sub ビジュアル動作()

　　Dim ws As Worksheet

　　Set ws = ActiveSheet

　　Dim A As Long, B As Long, C As Long

　　A = ws.Range("B2").Value

　　B = ws.Range("B3").Value

　　C = ws.Range("B4").Value

　　Call VusualBacket(A, B, C, ws.Range("D2"))

End Sub


Sub VusualBacket(ByVal A As Long, _

　　　　　　　　 ByVal B As Long, _

　　　　　　　　 ByVal C As Long, _

　　　　　　　　 ByVal argRng As Range)

　　Dim ws As Worksheet

　　Set ws = argRng.Worksheet

　　

　　argRng.Value = "バケツ" & A & "Lとバケツ" & B & "Lから" & C & "Lを作る"

　　

　　Dim TopPos As Long

　　Dim UnitHeight As Long

　　TopPos = argRng.Offset(3).Top

　　UnitHeight = argRng.Offset(3).RowHeight

　　Call BacketAdjust(ws.Shapes("バケツ枠A2"), A, ws.Shapes("バケツ枠A1"), A, TopPos, UnitHeight)

　　Call BacketAdjust(ws.Shapes("バケツ枠B2"), B, ws.Shapes("バケツ枠B1"), B, TopPos, UnitHeight)

　　

　　Dim spA As Shape

　　Dim spB As Shape

　　Set spA = ws.Shapes("バケツA")

　　Set spB = ws.Shapes("バケツB")

　　

　　Call BacketAdjust(spA, 0, spB, 0, TopPos, UnitHeight)

　　

　　Dim ans, v, str, num1, num2, cnt

　　ans = ShortestProcedure(A, B, C)

　　If IsEmpty(ans) Then

　　　　MsgBox "答えを見つけられませんでした。"

　　　　Exit Sub

　　End If

　　

　　For Each v In ans(0)

　　　　DoEvents

　　　　Application.Wait Now() + TimeSerial(0, 0, 1)

　　　　cnt = cnt + 1

　　　　argRng.Offset(1).Value = cnt & "回. " & v

　　　　DoEvents

　　　　Application.Wait Now() + TimeSerial(0, 0, 1)

　　　　str = Right(v, 7)

　　　　num1 = Mid(str, 3, 1)

　　　　num2 = Mid(str, 7, 1)

　　　　Call BacketAdjustAni(spA, num1, spB, num2, TopPos, UnitHeight)

　　Next

End Sub


Function BacketAdjust(ByVal spA As Shape, _

　　　　　　　　　　　ByVal numA As Long, _

　　　　　　　　　　　ByVal spB As Shape, _

　　　　　　　　　　　ByVal numB As Long, _

　　　　　　　　　　　ByVal TopPos As Long, _

　　　　　　　　　　　ByVal UnitHeight As Long)

　　spA.Height = UnitHeight * numA

　　spB.Height = UnitHeight * numB

　　spA.Top = TopPos + UnitHeight * (9 - numA)

　　spB.Top = TopPos + UnitHeight * (9 - numB)

End Function


Function BacketAdjustAni(ByVal spA As Shape, _

　　　　　　　　　　　　 ByVal numA As Long, _

　　　　　　　　　　　　 ByVal spB As Shape, _

　　　　　　　　　　　　 ByVal numB As Long, _

　　　　　　　　　　　　 ByVal TopPos As Long, _

　　　　　　　　　　　　 ByVal UnitHeight As Long)

　　numA = numA * 10

　　numB = numB * 10

　　

　　Dim BeforeNumA As Long, BeforeNumB As Long

　　BeforeNumA = spA.Height / UnitHeight * 10

　　BeforeNumB = spB.Height / UnitHeight * 10

　　

　　Dim sA As Long, sB As Long

　　sA = IIf(BeforeNumA > numA, -1, 1)

　　sB = IIf(BeforeNumB > numB, -1, 1)

　　

　　Dim hA As Long, hB As Long

　　hA = BeforeNumA

　　hB = BeforeNumB

　　Do

　　　　If hA <> numA Then

　　　　　　hA = hA + sA

　　　　　　spA.Height = UnitHeight * (hA / 10)

　　　　　　spA.Top = TopPos + UnitHeight * (9 - (hA / 10))

　　　　End If

　　　　If hB <> numB Then

　　　　　　hB = hB + sB

　　　　　　spB.Height = UnitHeight * (hB / 10)

　　　　　　spB.Top = TopPos + UnitHeight * (9 - (hB / 10))

　　　　End If

　　　　DoEvents

　　　　If hA = numA And hB = numB Then Exit Do

　　　　Application.Wait [NOW()+"0:0:0.05"]

　　Loop

      End Function

シートの設定がありますので、
以下よりダウンロードできるようにしてあります。

zipとxlsmを用意しました。

Backet3L5L.zip　Backet3L5L.xlsm

他のゲーム（数独、オセロ、将棋、囲碁）も含めたダウンロード一覧は以下になります。

エクセルのサンプルダウンロード

同じテーマ「ツイッター出題回答」の記事

「VBA Match関数の限界」についての誤解
 VBAで数値を漢数字に変換する方法
 囲碁で相手の石を囲んで取るアルゴリズム
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く
言語依存の関数を使用できるFormulaLocal
配列のUBoundがLBoundがより小さいことはあり得るか
 コレクションの要素を削除する場合
 greeenはgreenに、greeeeeNをGReeeeNに変換
 数値変数の値を別の変数を使わずに入れ替える
 Rangeオブジェクトを受け取り"行数,列数"で埋める
 数式の関数の使用回数、関数名を配列で返す

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門

ホーム
エクセル全般
ツイッター出題回答
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

ツイッター出題回答
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く