VBAで「3Lと5Lのバケツで4Lの水を作る」を解く
ツイッターでVBAのお題として出したものです。
「3Lと5Lのバケツで4Lの水を作る」
これを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実装方法:連ツイによる説明
以下は、ほぼ原文のままですが一部補正しています。
まず、このような問題は恐らく相応のアルゴリズムがあり、そのような勉強をしている人は○○探索だろ、みたいなものがるのだろうと思います。
残念ながら私はそのような勉強をしたことが無い、、、
(というか勉強全般しいてないw)
今回に限らず、ゲーム作る時はほぼ毎回そうなのですが、頭の中で考えて持っている知識の範囲で解く方法を考えています。ただし、もちろんその過程で困った時は一部はググって解決します。
教科書的な解法を知りたい人は、書籍を探して読んでください。
ただし、大筋では似たようなことをしているのではないかと思います。
・満タンにする
・空にする
・相手の容器に移す
つまり、ある場面での操作は6通り存在します。
これを全パターン試していたら、とても膨大な数になってしまいます。
1→6→6^2→6^3→・・・
数回の手順で数万に達してしまいます。
しかし、無限に繰り返されるパターンが出てくるとPCでもどうしようもなくなってしまいます。
そこで、大抵のゲームには無限に繰り返されることをどこかで制限するルールが存在します。
今回のバケツの問題も実はこの制限をしっかりかけています。
それは
「最短手順を示してください。」
最後のこの一文になります。
これが無いと、バケツAを満タン→空、これを繰り返すことが意味を持ってしまうので答えが無限に発生してしまいます。
それは、ある場面での操作の結果が以前の状態と同じ状態になる操作は意味を為さないという事です。
例えば、
A3L,B5Lとなった場合、次の操作はA3L,B0LまたはA0L,B5Lにしかなりません。
これは最初の操作でどちらかのバケツを満タンにした状態と同じです。
それ以降の探索は意味がなくなるので打ち切っても良いという事です。
さらに、3つの操作のうち無効な操作が常に存在します。
Aが満タンの時には、
・Aを満タン
・B→A
少なくともこの2つの操作は無効になります。
決して1→6→6^2とは増えていきません。
ある場面の次の状態は大体2~3通りしか存在しません。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
この2点をしっかりプログラミングすれば良いという事です。
この図では、無効な操作および過去に戻ってしまう操作を消しています。
レベル2の(3,5)は先に説明したように(0,5)(3,0)のどちらかになるのでレベル1に戻ってしまいます。
したがってここで終了となっています。
※太線は答えのルートです。
2つのバケツに3通りの操作と考えると途方もなく感じてしまいますが、実際に操作できる数は極めて少ないです。
ただし人間が頭の中で考えた時はそんなにスムーズにいきません。
過去に存在した状態を全て記憶していられないからです。
しかしコンピューターはそれが得意です。
というか、むしろそれしか出来ないと言っても良いと思いますが、、、
再度書きます。
・行える操作をしっかり限定する
・過去と同じになったらそのルートは終了
これをVBAで書けばよいのです。
まず、「バケツ」クラスを作成しました。
ルールの範囲内に限定したプロパティ・メソッドのみ作成しました。
したがって間違って設定させたくないプロパティは読み取り専用プロパティにしています。
Property Get Name
Property Get MaxValue
Property Get Value
Function Full
Function Emptied … Emptyは予約語
Function Transfer
Sub Receive … Transferで貰う時
※Name,MaxValue,Valueは読み取り専用、他のメソッドで設定
Full,Emptied,Transferの戻り型はBooleanです。
操作が有効な場合True/無効な場合False
つまり3つの操作でFalseが返ってきた場合は無効なので打ち切ります。
これで、
・行える操作をしっかり限定する
これが完成です。
・過去と同じになったらそのルートは終了
このためには、状態の保存が必要です。
先に出した以下の図、これをそのまま配列として持ちます。
縦のレベルを1次元配列として作り、その各要素の中に横に展開されている複数状態を配列として入れます。
いわゆるジャグ配列です。
単純な1次元だけで展開し、チェーンのようなものを付けていくと言った方法も使われたりするかもしれません。
今回の場合は「最短手順」がキーとなっているので、縦がそのまま手順回数になるので都合が良かったのでこのようにしてみました。
答えにたどり着いたとき、ルート(操作手順)が分かるようにしておかなければなりません。
この時にも、実装方法は大きく分かれると思います。
・開始からのルート情報を入れておく
・親を示すポインタを入れておく
VBAのコード量としては、前者の方が短くて済んだ気がします。
この辺りは、試行回数をどの程度で予測するかによるかもしれません。
何よりその時の気分で決めたしまったというのが本当のところです。
実際には使っていない情報も含めて配列に格納しています。
親の情報と自身の情報を目いっぱい入れました。
メモリや処理速度を気にするようなものではないことは分っている事でしたので。
・自身ユニーク番号
・親のユニーク番号
・親のレベル内での位置
・自身のレベル
・自身のレベル内での位置
・自身の名前
・実行メソッド
・移す場合の相手の名前
・自身の最大容量
・相手の最大容量
・自身の水量
・相手の水量
やはり、こういう時はユーザー定義型は使えないですね。
以上で準備は完了です。
メインとなるプロシージャーで、2つのバケツに対して3通りのメソッドを答えにたどり着くまで繰り返していきます。
その後は、レベル内(親のレベル)の配列を順次取り出し、
取り出した情報でバケツ2つを再作成して、3つのメソッドをそれぞれに実行します。
有効なメソッドは順次レベル+1の配列に入れていきます。
答えが無ければ、レベルを+1してループします。
一応、同一レベルに複数解があれば出るはずなのですが、そのような数値の組み合わせがあるのかどうか分かりません。
この連ツイと共に、VBAソースコードは明日記事として公開する予定でいます。
作成したVBAの全コード
「バケツ」クラス
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
「配列格納情報」クラス
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
これになります。
こちらは、あくまでイミディエイト ウィンドウにきれいに表示するためのプロシージャーです。
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
シートの設定がありますので、
以下よりダウンロードできるようにしてあります。
他のゲーム(数独、オセロ、将棋、囲碁)も含めたダウンロード一覧は以下になります。
同じテーマ「ツイッター出題回答 」の記事
「VBA Match関数の限界」についての誤解
VBAで数値を漢数字に変換する方法
囲碁で相手の石を囲んで取るアルゴリズム
VBAで「3Lと5Lのバケツで4Lの水を作る」を解く
言語依存の関数を使用できるFormulaLocal
配列のUBoundがLBoundがより小さいことはあり得るか
コレクションの要素を削除する場合
greeenはgreenに、greeeeeNをGReeeeNに変換
数値変数の値を別の変数を使わずに入れ替える
Rangeオブジェクトを受け取り"行数,列数"で埋める
数式の関数の使用回数、関数名を配列で返す
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.マクロとは?VBAとは?VBAでできること|VBA入門
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。