人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

私が持ってる玩具でジャマイカというのがあるのですが

http://www.masudaya.com/product/jamaica.html
これの最適解をExcelマクロで出す方法を考えてください。
詳細はコメント参照。


●質問者: きねーま
●カテゴリ:コンピュータ 学習・教育
✍キーワード:Excel コメント ジャマイカ マクロ 玩具
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●50ポイント

やっとこそれっぽいものができたので回答します。

Mookさんの作った実行シートが面白かったのでそのまま使えるようにしました。


処理はかなり重いので、非力のPCの場合ステータスバーのパーセント表示が進まないこともありえるので、

その場合はDoEventsを入れてあるので、VBEからマクロを停止してください。

(Core2Duo 2.4Ghzで50秒くらいでした)


コードにコメントをつけてなかったり短い名前の変数が乱立しているので見づらいことをお詫びします。

コードはもう少し短くすることもできましたが、更にわかりづらくなるのでやめました。

実行速度については、組み合わせやソートを書くことで、ある程度改善できますが、

コードが長くなるのでしていません。(ソートはシート上でやっています)

ロジック的には大丈夫だと思いますが、結果漏れがあるかどうかは完全に検証はできていません。

結果の重複も同じです。括弧の解釈によりある意味一定の重複は取り除けています。


Option Explicit

Public Type Enzan
 s As Double
 n As String
 k As Integer
End Type

Private r As Long
Private lngC As Long

Sub Shoot()
 Columns("B").Value = ""
 
 Dim c
 For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
 Range(c).Value = Int(Rnd() * 6) + 1
 Next
 Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

Sub jamaica()
 Application.ScreenUpdating = False
 Dim i As Integer
 Dim e(4) As Enzan
 
 Columns("AG").Value = ""
 Range("AF1:AF5").NumberFormatLocal = "@"
 
 r = 2
 lngC = 0
 
 For i = 0 To 4
 e(i).s = Range("Num" & i + 1).Value
 e(i).n = Range("Num" & i + 1).Value
 e(i).k = 2
 Next i

 Call Saiki(e, 4)

 If Range("B2") = "" Then Range("B2") = "NO ANSWER"
 Application.StatusBar = ""
 Range("AF1:AF5").Value = ""
 Columns("AG").Value = ""

 Application.ScreenUpdating = True
End Sub

Sub Saiki(e3() As Enzan, j As Integer)
 Dim i1 As Integer
 Dim i2 As Integer
 Dim i3 As Integer
 Dim s1 As Double
 Dim s2 As Double
 Dim n1 As String
 Dim n2 As String
 Dim k1 As Integer
 Dim k2 As Integer
 Dim c As Integer
 Dim i As Integer
 Dim e() As Enzan
 Dim e1() As Enzan
 Dim n5 As String
 Dim n6 As String
 Dim str As String
 
 For i1 = 0 To j
 For i2 = 0 To j
 If i1 <> i2 Then
 e = e3
 s1 = e(i1).s
 n1 = e(i1).n
 k1 = e(i1).k
 s2 = e(i2).s
 n2 = e(i2).n
 k2 = e(i2).k
 c = 0
 For i = 0 To j
 If i <> i1 And i <> i2 Then
 e(c) = e(i)
 c = c + 1
 End If
 Next i
 e1 = e
 For i3 = 0 To 3
 DoEvents
 lngC = lngC + 1
 Application.StatusBar = Int(lngC / 832592 * 100) & "%"
 e = e1
 n5 = n1
 n6 = n2
 Select Case i3
 Case 0
 e(j - 1).s = s1 + s2
 e(j - 1).n = n5 & "+" & n6
 e(j - 1).k = 0
 Case 1
 e(j - 1).s = s1 - s2
 If k2 < 2 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "-" & n6
 e(j - 1).k = 1
 Case 2
 e(j - 1).s = s1 * s2
 If k1 < 2 Then
 n5 = "(" & n1 & ")"
 End If
 If k2 < 2 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "*" & n6
 e(j - 1).k = 2
 Case 3
 If s2 = 0 Then Exit For
 e(j - 1).s = s1 / s2
 If k1 < 2 Then
 n5 = "(" & n1 & ")"
 End If
 If Len(n2) > 1 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "/" & n6
 e(j - 1).k = 3
 End Select
 e(j).s = 0
 e(j).n = ""
 e(j).k = 2
 If j > 1 Then
 Call Saiki(e, j - 1)
 Else
 If e(0).s = Range("GNum1").Value + Range("GNum2").Value Then
 str = Sort(e(0).n)
 If Range("AG:AG").Find(str) Is Nothing Then
 Cells(r, "AG").Value = str
 Cells(r, 2).Value = e(0).n
 r = r + 1
 End If
 End If
 End If
 Next i3
 End If
 Next i2
 Next i1
End Sub

Function Sort(ByVal s As String) As String
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 Dim h(9) As Variant
 Dim c As Integer
 Dim sp As Integer
 Dim ep As Integer
 Dim st As String
 Dim res As String
 Dim str As String
 
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "+", "-"
 If j = 0 Then
 f = True
 End If
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 End Select
 Next i
 
 j = 0
 sp = 1
 If f Then
 s = "+" & s
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "+", "-"
 If j = 0 Then
 If sp > 1 Then
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If
 c = c + 1
 End If
 h(c) = "+"
 st = Mid(s, i, 1)
 c = c + 1
 sp = i + 1
 End If
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 End Select
 Next i
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If
 Else
 s = "*" & s
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "*", "/"
 If j = 0 Then
 If sp > 1 Then
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If
 c = c + 1
 End If
 h(c) = "*"
 st = Mid(s, i, 1)
 c = c + 1
 sp = i + 1
 End If
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 End Select
 Next i
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If
 End If
 
 For i = 1 To 5
 Cells(i, "AF").Value = h(i * 2 - 1)
 Next i
 Range("AF1:AF5").Sort Key1:=Range("AF1")
 For i = 1 To 5
 h(i * 2 - 1) = Cells(i, "AF").Value
 Next i
 
 For i = 0 To 9
 res = res & h(i)
 Next
 
 Sort = res
End Function

Function Check(s As String) As Boolean
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 
 If Left(s, 1) = "(" And Right(s, 1) = ")" Then
 f = True
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 If j = 0 And i <> Len(s) Then
 f = False
 Exit For
 End If
 End Select
 Next i
 End If
 Check = f
End Function
◎質問者からの返答

いくつかの数字で動作確認しましたが、確かに速度に難はありますがきちんと動きました。

ただ素人目、結構重複している部分があるように見受けられるので更に最適化行けそうです。

(作った本人はもう弄りたくないって気分かもですが・・・)


2 ● SALINGER
●50ポイント

コード中に間違いがあったので修正しました。

質問では短いコードということでしたが、実行速度を早くする変更を加えましたのその分コードは長くなりました。


変更点は、組み合わせを作るときに1つ目と2つ目というように順番をつけて、演算子を引き算と割り算のときに逆の場合を追加したこと。これで3分の1くらいになりました。

更に、同じ数字がある場合に1度で済むようにしました。これにより同じ数字があるほど処理が早く終わるようになっています。

私の環境では、0秒?25秒くらいです。


Option Explicit

Public Type Enzan
 s As Double
 n As String
 k As Integer
End Type

Private r As Long
Private hai() As String
Private c1 As Integer

Sub Shoot()
 Columns("B").Value = ""
 Dim c
 For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
 Range(c).Value = Int(Rnd() * 6) + 1
 Next
 Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

Sub jamaica()
 Dim i As Integer
 Dim e(4) As Enzan
 Dim stTime
 ReDim hai(0)
 Dim en As Integer
 
 stTime = Time
 Range("AF1:AF5").NumberFormatLocal = "@"
 Columns("B").Value = ""
 
 Application.ScreenUpdating = False
 
 r = 2
 lngC = 0
 en = 1
 For i = 0 To 4
 e(i).s = Range("Num" & i + 1).Value
 e(i).n = Range("Num" & i + 1).Value
 e(i).k = 3
 en = en * e(i).s
 Next i

 If en >= Range("GNum1").Value + Range("GNum2").Value Then
 Call Saiki(e, 4)
 End If

 If Range("B2") = "" Then Range("B2") = "NO ANSWER"
 Application.StatusBar = DatePart("s", Time - stTime) & "秒"
 Range("AF1:AF5").Value = ""

 Application.ScreenUpdating = True
End Sub

Sub Saiki(e3() As Enzan, j As Integer)
 Dim i1 As Integer
 Dim i2 As Integer
 Dim i3 As Integer
 Dim s1 As Double
 Dim s2 As Double
 Dim n1 As String
 Dim n2 As String
 Dim k1 As Integer
 Dim k2 As Integer
 Dim c As Integer
 Dim i As Integer
 Dim e() As Enzan
 Dim e1() As Enzan
 Dim n5 As String
 Dim n6 As String
 Dim str As String
 Dim f2 As Boolean
 Dim f3 As Boolean
 Dim f4 As Boolean
 Dim h1(10) As String
 Dim h2(10) As String
 Dim c2 As Integer
 
 c2 = 0
 For i1 = 0 To j - 1
 For i2 = i1 + 1 To j
 f4 = False
 For i = 0 To c2
 If (h1(i) = e3(i1).n And h2(i) = e3(i2).n) Or (h1(i) = e3(i2).n And h2(i) = e3(i1).n) Then
 f4 = True
 Exit For
 End If
 Next i
 If Not f4 Then
 c2 = c2 + 1
 h1(c2) = e3(i1).n
 h2(c2) = e3(i2).n
 
 e = e3
 s1 = e(i1).s
 n1 = e(i1).n
 k1 = e(i1).k
 s2 = e(i2).s
 n2 = e(i2).n
 k2 = e(i2).k
 c = 0
 For i = 0 To j
 If i <> i1 And i <> i2 Then
 e(c) = e(i)
 c = c + 1
 End If
 Next i
 e1 = e
 For i3 = 0 To 5
 DoEvents
 f2 = False
 e = e1
 n5 = n1
 n6 = n2
 Select Case i3
 Case 0
 e(j - 1).s = s1 + s2
 e(j - 1).n = n5 & "+" & n6
 Case 1
 e(j - 1).s = s1 - s2
 If k2 < 3 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "-" & n6
 Case 2
 e(j - 1).s = s2 - s1
 If k1 < 3 Then
 n5 = "(" & n1 & ")"
 End If
 e(j - 1).n = n6 & "-" & n5
 Case 3
 e(j - 1).s = s1 * s2
 If k1 < 3 Then
 n5 = "(" & n1 & ")"
 End If
 If k2 < 3 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "*" & n6
 Case 4
 If s2 <> 0 Then
 e(j - 1).s = s1 / s2
 If k1 < 3 Then
 n5 = "(" & n1 & ")"
 End If
 If Len(n2) > 1 Then
 n6 = "(" & n2 & ")"
 End If
 e(j - 1).n = n5 & "/" & n6
 Else
 f2 = True
 End If
 Case 5
 If s1 <> 0 Then
 e(j - 1).s = s2 / s1
 If k2 < 3 Then
 n6 = "(" & n2 & ")"
 End If
 If Len(n1) > 1 Then
 n5 = "(" & n1 & ")"
 End If
 e(j - 1).n = n6 & "/" & n5
 Else
 f2 = True
 End If
 End Select
 If Not f2 Then
 e(j - 1).k = i3
 e(j).s = 0
 e(j).n = ""
 e(j).k = 3
 If j > 1 Then
 Call Saiki(e, j - 1)
 Else
 If e(0).s = Range("GNum1").Value + Range("GNum2").Value Then
 str = Sort(e(0).n)
 f3 = False
 For i = 0 To UBound(hai)
 If hai(i) = str Then
 f3 = True
 Exit For
 End If
 Next i
 If Not f3 Then
 ReDim Preserve hai(c1)
 hai(c1) = str
 c1 = c1 + 1
 Cells(r, 2).Value = e(0).n
 r = r + 1
 End If
 End If
 End If
 End If
 Next i3
 End If
 Next i2
 Next i1
End Sub

Function Sort(ByVal s As String) As String
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 Dim h(9) As Variant
 Dim c As Integer
 Dim sp As Integer
 Dim ep As Integer
 Dim st As String
 Dim res As String
 Dim str As String
 Dim m1 As String
 Dim m2 As String
 
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "+", "-"
 If j = 0 Then
 f = True
 End If
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 End Select
 Next i
 
 j = 0
 sp = 1
 If f Then
 m1 = "+"
 m2 = "-"
 Else
 m1 = "*"
 m2 = "/"
 End If
 s = m1 & s
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case m1, m2
 If j = 0 Then
 If sp > 1 Then
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If
 c = c + 1
 End If
 h(c) = m1
 st = Mid(s, i, 1)
 c = c + 1
 sp = i + 1
 End If
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 End Select
 Next i
 str = Mid(s, sp, i - sp)
 If i - sp > 1 Then
 If Check(str) Then
 h(c) = st & "(" & Sort(Mid(str, 2, Len(str) - 2)) & ")"
 Else
 h(c) = st & Sort(str)
 End If
 Else
 h(c) = st & str
 End If

 
 For i = 1 To 5
 Cells(i, "AF").Value = h(i * 2 - 1)
 Next i
 Range("AF1:AF5").Sort Key1:=Range("AF1")
 For i = 1 To 5
 h(i * 2 - 1) = Cells(i, "AF").Value
 Next i
 
 For i = 0 To 9
 res = res & h(i)
 Next
 
 Sort = res
End Function

Function Check(s As String) As Boolean
 Dim i As Integer
 Dim j As Integer
 Dim f As Boolean
 
 If Left(s, 1) = "(" And Right(s, 1) = ")" Then
 f = True
 For i = 1 To Len(s)
 Select Case Mid(s, i, 1)
 Case "("
 j = j + 1
 Case ")"
 j = j - 1
 If j = 0 And i <> Len(s) Then
 f = False
 Exit For
 End If
 End Select
 Next i
 End If
 Check = f
End Function

更なる高速化については、最初に式が成り立つかだけを計算して、成り立つ組み合わせだけを

後から文字列を作るという方法が考えられますが、大幅な変更が必要になるので今回は辞めておきます。

また、初回に別のシートに組み合わせのデータベースを作るという方法もあります。

その場合は初回だけ時間が掛かりますが、2回目以降は瞬時に結果が出るでしょう。

それは気が向いたらブログの方に作るかもしれません。


3 ● Mook
●200ポイント ベストアンサー

何とか締め切りに間に合ったでしょうか。


ぎりぎりになったので、チェック漏れがあるかもしれませんが何となく動いているので回答します。

コードは一応下記に張っておきますがこれだけでは動きませんので、動作版はお手数ですがダイアリーを参照ください。


下準備

(1)まず、5つの数字の組み合わせによる四則演算の式は2048通りあります。

(2)これらのうち変形することによって同じ式になるものをまとめると、374通りになります。

(3)さらにこれらの式のうちサイコロの数値(1?6)を使用して11以上になるものは233通りです。

これはジャマイカにおいては一意に決まるものですから、あらかじめ用意しておきます。

(VBA では Expression というシートのA列にあることを前提にしています。)


さて実際の処理ですが、サイコロの目のパターン(最大120通り:重複によりこれ以下)をこの233通りにあてはめて計算することによって

最大の計算数を 120*233 以内で結果を出すことができます。


こちらでの実行結果はだいたい2?6秒くらいでした。

参考までにコードを提示します。

Option Explicit

Public Goal As Long  '// 目標値(黒ダイスの合計)
Public DiceArray(4) As Long  '// 白ダイス
Public OutRow As Long  '// 結果出力行

'-----------------------------------------------------------------
Sub Shoot()
'-----------------------------------------------------------------
 Columns("B").Value = ""
 
 Dim c
 For Each c In Array("Num1", "Num2", "Num3", "Num4", "Num5", "GNum2")
 Range(c).Value = Int(Rnd() * 6) + 1
 Next
 Range("GNum1").Value = 10 * (Int(Rnd() * 6) + 1)
End Sub

'-----------------------------------------------------------------
Sub Jamaica()
'-----------------------------------------------------------------
 Dim d, i As Long
 For Each d In Array("Num1", "Num2", "Num3", "Num4", "Num5")
 DiceArray(i) = Range(d)
 i = i + 1
 Next
 Goal = Range("GNum1").Value + Range("GNum2").Value
 
 If getMax() < Goal Then
 Range("B2") = "No Answer"
 Exit Sub
 End If
 OutRow = 2
 
 Dim comArray
 comArray = makeNumArray()
 
 Dim com, r As Long
 r = 1
 Do While Worksheets("Expression").Cells(r, "A") <> ""
 For Each com In comArray
 If expCalc(Worksheets("Expression").Cells(r, "A"), com) = True Then Exit For
 Next
 r = r + 1
 Loop
 If OutRow = 2 Then
 Cells(OutRow, "B") = "No Answer"
 Else
 Cells(OutRow, "B") = "END"
 End If
End Sub

'-----------------------------------------------------------------
Function expCalc(exp, com) As Boolean
'-----------------------------------------------------------------
 expCalc = False
 Dim i As Long, j As Long, ch As String
 Dim dstExp As String
 j = 1
 For i = 1 To Len(exp)
 ch = Mid(exp, i, 1)
 If ch = "#" Then
 dstExp = dstExp & Mid(com, j, 1)
 j = j + 1
 Else
 dstExp = dstExp & ch
 End If
 Next
 If CLng(Evaluate(dstExp)) = Goal Then
 Cells(OutRow, "B") = dstExp
 OutRow = OutRow + 1
 expCalc = True
 End If
End Function

'-----------------------------------------------------------------
Function makeNumArray()
'-----------------------------------------------------------------
 Dim objDic
 Dim cm As String
 Dim i1, i2, i3, i4, i5, ar1, ar2, ar3, ar4, ar5
 Set objDic = CreateObject("Scripting.Dictionary")
 For Each i1 In Array(0, 1, 2, 3, 4)
 ar2 = Replace(Replace("0,1,2,3,4,@", i1 & ",", ""), ",@", "")
 For Each i2 In Split(ar2, ",")
 ar3 = Replace(Replace(ar2 & ",@", i2 & ",", ""), ",@", "")
 For Each i3 In Split(ar3, ",")
 ar4 = Replace(Replace(ar3 & ",@", i3 & ",", ""), ",@", "")
 For Each i4 In Split(ar4, ",")
 i5 = CInt(Replace(Replace(ar4 & ",@", i4 & ",", ""), ",@", ""))
 cm = DiceArray(i1) & DiceArray(i2) & DiceArray(i3) & DiceArray(i4) & DiceArray(i5)
 If Not objDic.Exists(cm) Then
 objDic.Add cm, ""
 End If
 Next
 Next
 Next
 Next

 makeNumArray = objDic.keys
End Function

'-----------------------------------------------------------------
Function getMax() As Long
'-----------------------------------------------------------------
 Dim n%(7), i%, j%
 
 For i = 0 To 4
 n(DiceArray(i)) = n(DiceArray(i)) + 1
 Next
 
 Do While n(1) > 0
 n(1) = n(1) - 1
 For i = 1 To 6
 If n(i) > 0 Then
 n(i) = n(i) - 1
 n(i + 1) = n(i + 1) + 1
 Exit For
 End If
 Next
 Loop
 
 getMax = 1
 For i = 1 To 7
 For j = 1 To n(i)
 getMax = getMax * i
 Next
 Next
End Function
◎質問者からの返答

短い!しかも分かりやすい!!

お疲れ様でした。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ