ナンバープレート数字遊び：ツイッターお題

最終更新日：2020-08-23

ナンバープレート数字遊び：ツイッターお題

ツイッターで出されたお題をVBAで回答したものです。

車のナンバープレートの4つの数字でやったりするお遊びです。
ナンバーの4つの数字を四則演算で10にするというものです・

【問題】
1-9までの数字が4つ与えられます
それらを加減乗除を用いて10を作りたい
その解答を全て列挙するプログラムを作成しなさい
（解答なしの場合は「なし」）

お題のツイート

https://twitter.com/toshi81350036/status/1297038925177839617

他の方達の回答および私の回答ツイートは上記ツイートから辿ってみてください。

回答のVBA

即興で作ったので、VBA記述が汚いのはご容赦を。
また、無駄（同じ数式じゃないのか等）な数式も含まれていたりすると思いますが、この点もご容赦を。


  
    
      Function Number10(a, b, c, d, Optional optPrint As Boolean = True)

　　Dim strCalc 'abcは数値、xyzは演算子

　　strCalc = Array("a x b y c z d", _

　　　　　　　　　　"(a x b) y c z d", _

　　　　　　　　　　"a x (b y c) z d", _

　　　　　　　　　　"a x b y (c z d)", _

　　　　　　　　　　"(a x c y b) z d", _

　　　　　　　　　　"a x (b y c z d)", _

　　　　　　　　　　"(a x b) y (c z d)", _

　　　　　　　　　　"((a x b) y c) z d", _

　　　　　　　　　　"(a x (b y c)) z d", _

　　　　　　　　　　"a x ((b y c) z d)", _

　　　　　　　　　　"a x (b y (c z d))")

　　Dim numAry '数値配列

　　Call permutation(Array(a, b, c, d), numAry)

　　Dim opeAry '演算子配列

　　opeAry = getOpeArray

　　

　　Dim dic As Object

　　Set dic = CreateObject("Scripting.Dictionary")

　　Dim i, i1, i2, i3, tmpCalc

　　For i1 = LBound(strCalc) To UBound(strCalc)

　　　　For i2 = LBound(numAry, 2) To UBound(numAry, 2)

　　　　　　For i3 = LBound(opeAry, 1) To UBound(opeAry, 1)

　　　　　　　　tmpCalc = strCalc(i1)

　　　　　　　　tmpCalc = Replace(tmpCalc, "x", opeAry(i3, 0))

　　　　　　　　tmpCalc = Replace(tmpCalc, "y", opeAry(i3, 1))

　　　　　　　　tmpCalc = Replace(tmpCalc, "z", opeAry(i3, 2))

　　　　　　　　tmpCalc = Replace(tmpCalc, "a", numAry(0, i2))

　　　　　　　　tmpCalc = Replace(tmpCalc, "b", numAry(1, i2))

　　　　　　　　tmpCalc = Replace(tmpCalc, "c", numAry(2, i2))

　　　　　　　　tmpCalc = Replace(tmpCalc, "d", numAry(3, i2))

　　　　　　　　tmpCalc = delKakko(tmpCalc) '無駄な括弧()を消す

　　　　　　　　If Not dic.Exists(tmpCalc) Then

　　　　　　　　　　dic.Add tmpCalc, tmpCalc

　　　　　　　　End If

　　　　　　Next

　　　　Next

　　Next

　　

　　Dim v, ans, cnt

　　cnt = 0

　　For Each v In dic

　　　　On Error Resume Next

　　　　ans = Evaluate(v)

　　　　If IsNumeric(ans) Then

　　　　　　If ans = 10 Then

　　　　　　　　cnt = cnt + 1

　　　　　　　　If optPrint Then Debug.Print v; " ="; ans

　　　　　　End If

　　　　End If

　　Next

　　Number10 = cnt

End Function


Function delKakko(ByVal argCalc As String) As String

　　delKakko = argCalc

　　Dim strCalc, i, i1, i2, ix

　　

　　On Error Resume Next

　　For i = 1 To 2

　　　　ix = 1

　　　　If i = 2 Then

　　　　　　ix = InStr(delKakko, "(") + 1

　　　　End If

　　　　i1 = InStr(ix, delKakko, "(")

　　　　If i1 = 0 Then Exit For

　　　　i2 = PairKakko(delKakko, i1)

　　　　strCalc = delKakko

　　　　Mid(strCalc, i1, 1) = " "

　　　　Mid(strCalc, i2, 1) = " "

　　　　'()を外して計算結果が同じなら同じ数式とする。

　　　　'正しくは違うと思うが、簡易的に無駄な()を消すため

　　　　If Evaluate(strCalc) = Evaluate(delKakko) Then

　　　　　　delKakko = strCalc

　　　　End If

　　Next

　　

　　delKakko = Trim(Replace(Replace(delKakko, "　", " "), "　", " "))

End Function


Function PairKakko(ByVal strCalc As String, ByVal i1 As Long)

　　Dim i As Long, cnt As Long

　　For i = i1 + 1 To Len(strCalc)

　　　　If Mid(strCalc, i, 1) = "(" Then cnt = cnt - 1

　　　　If cnt = 0 And Mid(strCalc, i, 1) = ")" Then

　　　　　　PairKakko = i

　　　　End If

　　Next

End Function


Function getOpeArray()

　　Dim opeAry(63, 2) As String '4*4*4-1=63

　　Dim i1, i2, i3, i4

　　Dim cnsAry: cnsAry = Array("+", "-", "*", "/")

　　For i1 = 0 To 63

　　　　For i2 = 0 To 3

　　　　　　For i3 = 0 To 3

　　　　　　　　For i4 = 0 To 3

　　　　　　　　　　opeAry(i1, 0) = cnsAry(i2)

　　　　　　　　　　opeAry(i1, 1) = cnsAry(i3)

　　　　　　　　　　opeAry(i1, 2) = cnsAry(i4)

　　　　　　　　　　i1 = i1 + 1

　　　　　　　　Next

　　　　　　Next

　　　　Next

　　Next

　　getOpeArray = opeAry

End Function


Sub permutation(ByRef aryIn, ByRef aryOut, Optional ByVal i As Long = 0)

　　Dim j As Long, ix As Long

　　Dim ary, sTemp

　　If i < UBound(aryIn) Then

　　　　For j = i To UBound(aryIn)

　　　　　　ary = aryIn

　　　　　　sTemp = aryIn(i)

　　　　　　aryIn(i) = aryIn(j)

　　　　　　aryIn(j) = sTemp

　　　　　　Call permutation(aryIn, aryOut, i + 1)

　　　　　　aryIn = ary

　　　　Next

　　Else

　　　　If IsEmpty(aryOut) Or Not IsArray(aryOut) Then

　　　　　　ix = 0

　　　　　　ReDim aryOut(UBound(aryIn), ix)

　　　　Else

　　　　　　ix = UBound(aryOut, 2) + 1

　　　　　　ReDim Preserve aryOut(UBound(aryIn), ix)

　　　　End If

　　　　For j = LBound(aryIn) To UBound(aryIn)

　　　　　　aryOut(j, ix) = aryIn(j)

　　　　Next j

　　End If

End Sub

では、実際に数値を入れてテストしてみます。


  
    
      Sub main()

　　Debug.Print vbLf & "3, 9, 3, 9"

　　Debug.Print Number10(3, 9, 3, 9)

　　Debug.Print vbLf & "2, 3, 5, 7"

　　Debug.Print Number10(2, 3, 5, 7)

　　Debug.Print vbLf & "2, 3, 5, 8"

　　Debug.Print Number10(2, 3, 5, 8)

End Sub

結果は、イミディエイトウィンドウに出力されます。

(3, 9, 3, 9)
3 / 9 * 3 + 9 = 10 
3 * 3 + 9 / 9 = 10 
3 * 3 / 9 + 9 = 10 
9 + 3 * 3 / 9 = 10 
9 / 3 / 3 + 9 = 10 
9 + 3 / 9 * 3 = 10 
9 + 9 / 3 / 3 = 10 
9 / 9 + 3 * 3 = 10 
3 / (9 / 3) + 9 = 10 
9 / (3 * 3) + 9 = 10 
9 + 3 / (9 / 3) = 10 
9 + 9 / (3 * 3) = 10 
3 * 3 + (9 / 9) = 10 
9 / 9 + (3 * 3) = 10 
 14 
(2, 3, 5, 7)
2 + 3 * 5 - 7 = 10 
2 + 5 * 3 - 7 = 10 
2 - 7 + 5 * 3 = 10 
2 - 7 + 3 * 5 = 10 
3 * 5 + 2 - 7 = 10 
3 * 5 - 7 + 2 = 10 
5 * 3 + 2 - 7 = 10 
5 * 3 - 7 + 2 = 10 
(3 + 7) / 2 + 5 = 10 
(7 - 3) * 5 / 2 = 10 
(7 + 3) / 2 + 5 = 10 
(7 - 3) / 2 * 5 = 10 
(7 - 2) * 3 - 5 = 10 
3 * (7 - 2) - 5 = 10 
5 + (3 + 7) / 2 = 10 
5 + (7 + 3) / 2 = 10 
5 * (7 - 3) / 2 = 10 
3 * 5 - (7 - 2) = 10 
5 * 3 - (7 - 2) = 10 
5 / 2 * (7 - 3) = 10 
(3 + 7 - 5) * 2 = 10 
(3 - 5 + 7) * 2 = 10 
(7 - 5 + 3) * 2 = 10 
(7 - 2 - 3) * 5 = 10 
(7 + 3 - 5) * 2 = 10 
(7 - 3 - 2) * 5 = 10 
2 * (3 - 5 + 7) = 10 
2 * (3 + 7 - 5) = 10 
2 - (7 - 5 * 3) = 10 
2 * (7 - 5 + 3) = 10 
2 - (7 - 3 * 5) = 10 
2 * (7 + 3 - 5) = 10 
5 * (7 - 2 - 3) = 10 
5 / (7 / 2 - 3) = 10 
5 * (7 - 3 - 2) = 10 
(2 + 3) * (7 - 5) = 10 
2 - 7 + (5 * 3) = 10 
2 - 7 + (3 * 5) = 10 
(2 - 7) * (3 - 5) = 10 
(3 + 2) * (7 - 5) = 10 
(3 - 5) * (2 - 7) = 10 
3 * 5 + (2 - 7) = 10 
5 * 3 + (2 - 7) = 10 
(5 - 3) * (7 - 2) = 10 
(7 - 3) / (2 / 5) = 10 
(7 - 5) * (3 + 2) = 10 
(7 - 5) * (2 + 3) = 10 
(7 - 2) * (5 - 3) = 10 
 48 
(2, 3, 5, 8)
(8 - 2) * 5 / 3 = 10 
(8 - 2) / 3 * 5 = 10 
5 * (8 - 2) / 3 = 10 
5 / 3 * (8 - 2) = 10 
(8 - 2 * 3) * 5 = 10 
(8 - 3 * 2) * 5 = 10 
5 * (8 - 2 * 3) = 10 
5 * (8 - 3 * 2) = 10 
(8 - 2) / (3 / 5) = 10 
 9

ナンバープレート数字遊びで10に出来ない数字の組み合わせ

上記は与えられた4つの数値で10にできる数式を求めたものです。
では、1111～9999において10に出来ない数値の組み合わせはあるでしようか。
これは、もちろん存在します。
例えば、1,1,1,1、これはどうやっても10にはできません。
このような数値の組み合わせを列挙してみましょう。

このとき、4つの数値の順番は意味を為しません。
数式作成で順番を入れ替えて、全ての組み合わせで数式を作るからです。
1,1,1,2
1,1,2,1
1,2,1,1
2,1,1,1
これらは数式作成で同じものになってしまいます。
1111～9999の実行は、時間がかなりかかりますので、
このように同じ数値の組み合わせは省くようにVBAを組んでテストしてみました。


  
    
      Sub main2()

　　Dim dic

　　Set dic = CreateObject("Scripting.Dictionary")

　　Dim i1, i2, i3, i4, cnt, str

　　For i1 = 1 To 9

　　　　For i2 = 1 To 9

　　　　　　For i3 = 1 To 9

　　　　　　　　For i4 = 1 To 9

　　　　　　　　　　str = Join(WorksheetFunction.Sort(Array(i1, i2, i3, i4), 1, 1, True), ",")

　　　　　　　　　　If Not dic.Exists(str) Then

　　　　　　　　　　　　dic.Add str, str

　　　　　　　　　　　　Application.StatusBar = str

　　　　　　　　　　　　DoEvents

　　　　　　　　　　　　cnt = Number10(i1, i2, i3, i4, False)

　　　　　　　　　　　　If cnt = 0 Then

　　　　　　　　　　　　　　Debug.Print str

　　　　　　　　　　　　End If

　　　　　　　　　　End If

　　　　　　　　Next

　　　　　　Next

　　　　Next

　　Next

End Sub

結果です。

1,1,1,1
1,1,1,2
1,1,1,3
1,1,2,2
1,1,5,9
1,1,6,9
1,1,7,7
1,1,7,8
1,1,7,9
1,1,8,8
1,3,9,9
1,4,4,4
1,4,9,9
1,6,6,6
1,6,6,7
1,6,7,7
1,6,9,9
1,7,7,7
2,2,5,7
3,4,4,4
3,6,6,9
3,7,7,9
3,9,9,9
4,4,4,4
4,4,5,9
4,4,7,7
4,5,5,8
4,8,9,9
4,9,9,9
5,6,6,8
5,7,8,8
5,7,9,9
5,8,9,9
6,6,6,6
6,6,6,7
6,6,7,7
6,7,7,7
6,7,7,8
6,8,8,8
6,8,9,9
6,9,9,9
7,7,7,7
7,7,8,8
7,7,8,9
7,7,9,9
7,8,8,8
7,9,9,9
8,8,9,9

案外少ないような、むしろ多いような・・・
すみません、そもそも本当に合っているのさえ良く分かっていません。
確かめるには、自力で数式組んでみるしかないので・・・

同じテーマ「エクセル雑感」の記事

ツイッターのお題「君の名は？」
ツイッターのお題「CSV編集」
アルファベットの26進（ツイッターお題）
ナンバープレート数字遊び：ツイッターお題
保護されたブックの非表示シートについて
 文字列のセルだけ結合
 時間に関する関数の扱い方
 COUNTIF関数の結果は?
【超難問】エクセル数式問題
 IFステートメントの判定
 日付の謎：IsDateとCDate

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.変数宣言のDimとデータ型｜VBA入門
4.マクロって何？VBAって何？｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
8.セルに文字を入れるとは（Range,Value）｜VBA入門
9.とにかく書いてみよう（Sub,End Sub）｜VBA入門
10.繰り返し処理（Do Loop）｜VBA入門

ホーム
エクセル全般
エクセル雑感
ナンバープレート数字遊び：ツイッターお題

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

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

エクセル雑感
ナンバープレート数字遊び：ツイッターお題