数珠順列（配置に条件付き）を全て出力する

最終更新日：2022-08-21

数珠順列（配置に条件付き）を全て出力する

ツイッターで出したエクセルVBAの問題です。

一般的には数珠順列という問題になるそうです。
赤玉、白玉、青玉
それぞれの個数を決めて、配置に制限を設けた時の全ての配置パターンを出力するという問題です。

出題元のツイート

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

ここは手作業で1つずつ数えていくという暴挙に出ました(笑)
最後はなんとか正解にたどり着いたようです。

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

出題ツイート

【VBA問題】※言語は問わないけど一応
白玉2個、赤玉4個、青玉5個を数珠つなぎにする。
どの赤玉も隣り合わないように配置するとき、配置パターンを全て出力せよ。
例：赤,青,赤,白,赤,青,赤,青,白,青,青
※今回は白は2個ですよ

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

お借りした問題じゃなければ、100本ノック魔球編の難しめくらいの問題だったかもしれませんね。
やるべきことははっきりしているのだけど、現実的な処理時間に収められるかが問題ですかね。

引用リツイートでの回答

引用リツイート

筆者自身も途中経過として、引用リツイートしています。

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

そもそも11の順列が、
39916800
こんなにあるんだ・・・
総当たりだと厳しいかな、、、
まあPCに頑張ってもらう事にしようwww

昨日に白1を手作業で解いた時間よりは、
今日プログラム書いて答えを出す時間の方が短かったですかね。
というか、白2を手作業では無理ですねwww

一応こんな風に出力して、条件付き書式で色付けてみた。
あれー、なんか偏ってねなー・・・
そうか、赤の隣に白が来ないパターンは1通りしかないのか・・・うーん、合ってるよね。
Excel エクセルVBA問題数珠順列

一応処理時間は3分くらいでした。
赤赤パターンを少し早めに打ち切っているので、全順列よりは少なくしてはいます。

出題者としての解答

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

「出題者としての解答」
単純な順列としては、
FACT(11)=39916800
このくらいの処理なら、最近のPCなら時間はかかっても処理出来ないことも無いだろうと見当をつけて開始です。
全順列を作る方法はいろいろあると思いますが、
再帰処理で配列の順番を入れ替えながら全順列を作るようにしました。

作成した順列の中から、赤玉が隣り合う配置パターンと、同色が複数あるので同一配置になるものを除外します。
さらに数珠なので輪にしたときに同一となる配置、さらに裏返したときに同じ配置になるパターンを除外します。
これらをどのように判定するかが難しいところですね。

赤玉の連続は簡単に判定できます。
輪にした時の判定をどうするか…
1つずつずらして回転させて判定…それはちょっと処理時間がかかってしまいそうです。
そこで配置パターンを2回繰り返してくっ付けます。
パターン1 & パターン1
この文字列内のどこかにパターン1があれば重複パターンと判定します。

ひっくり返したときの判定をどうするか…
これは単純に文字列を反転させれば良さそうです。
ただし、輪の判定なので2回繰り返した文字列の反転を使います。
1ンータパ & 1ンータパ
この文字列内のどこかにパターン1があれば重複パターンと判定します。

以上の考えを基にVBAを作成しました。
実際のVBAコードでは、処理速度を考慮して判定順序等の工夫をしています。
特に赤玉の連続は早めに打ち切るようにしています。
手元のPCでは、
160秒くらいで出力できています。
VBAコードを掲載しました。
https://excel-ubara.com/excel5/EXCEL89903.html


  
    
      Sub main()

　　Dim st: st = Timer

　　

　　Dim aryIn, aryOut

　　aryIn = Split("赤,赤,赤,赤,白,白,青,青,青,青,青", ",")

　　

　　'数珠順列作成再帰

　　Call permutation(aryIn, aryOut, LBound(aryIn))

　　

　　'シート出力

　　Call ary2sheet(aryOut, ActiveSheet, UBound(aryIn) - LBound(aryIn) + 1)

　　

　　MsgBox Timer - st

End Sub


'シート出力

Sub ary2sheet(ByRef aryOut, ByVal ws As Worksheet, ByVal col)

　　Dim ary

　　ReDim ary(LBound(aryOut, 2) To UBound(aryOut, 2), 1 To col)

　　

　　Dim i As Long, j As Long

　　For i = LBound(aryOut, 2) To UBound(aryOut, 2)

　　　　For j = 1 To col

　　　　　　ary(i, j) = Mid(aryOut(0, i), j, 1)

　　　　Next

　　Next

　　

　　ws.Cells.Clear

　　ws.Range("A1").Resize(UBound(ary, 1) - LBound(ary, 1) + 1, _

　　　　　　　　　　　　　UBound(ary, 2) - LBound(ary, 2) + 1).Value = ary

　　

　　'表示形式と条件付き書式

　　With ws.Columns("A").Resize(, UBound(ary, 2) - LBound(ary, 2) + 1)

　　　　.NumberFormat = """●"";""●"";""●"";""●"""

　　　　With .FormatConditions.Add(Type:=xlExpression, Formula1:="=A1=""赤""")

　　　　　　.Font.Color = vbRed

　　　　End With

　　　　With .FormatConditions.Add(Type:=xlExpression, Formula1:="=A1=""青""")

　　　　　　.Font.Color = vbBlue

　　　　End With

　　　　With .FormatConditions.Add(Type:=xlExpression, Formula1:="=A1=""白""")

　　　　　　.Font.Color = RGB(166, 166, 166)

　　　　End With

　　End With

End Sub


'数珠順列作成再帰

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

　　Dim j As Long, ix As Long

　　Dim sTemp, flg As Boolean

　　Dim ary

　　If i < UBound(aryIn) Then

　　　　For j = i To UBound(aryIn)

　　　　　　'配列を入れ替える

　　　　　　ary = aryIn

　　　　　　sTemp = aryIn(i)

　　　　　　aryIn(i) = aryIn(j)

　　　　　　aryIn(j) = sTemp

　　　　　　

　　　　　　'処理速度対応として赤赤は早めに除外する

　　　　　　flg = True

　　　　　　If i > LBound(aryIn) Then

　　　　　　　　sTemp = Left(Join(aryIn, ""), i - LBound(aryIn) + 1)

　　　　　　　　If sTemp Like "*赤赤*" Then flg = False

　　　　　　End If

　　　　　　

　　　　　　If flg Then

　　　　　　　　'再帰処理、開始位置を+1

　　　　　　　　Call permutation(aryIn, aryOut, i + 1)

　　　　　　End If

　　　　　　aryIn = ary '配列を元に戻す

　　　　Next

　　Else

　　　　'配列の最後まで行ったので出力

　　　　If IsEmpty(aryOut) Then '少しは速度対策になるかなと分けて処理

　　　　　　ix = 0

　　　　　　ReDim aryOut(2, ix)

　　　　　　Call aryIn2Out(aryIn, aryOut, ix)

　　　　ElseIf isRules(aryOut, aryIn) Then

　　　　　　ix = UBound(aryOut, 2) + 1

　　　　　　ReDim Preserve aryOut(2, ix)

　　　　　　Call aryIn2Out(aryIn, aryOut, ix)

　　　　End If

　　End If

End Sub


'入力配列を出力配列へ編集転記

Sub aryIn2Out(ByRef aryIn, ByRef aryOut, ByVal ix As Long)

　　'文字列に結合して格納

　　aryOut(0, ix) = Join(aryIn, "")

　　'輪の状態で重複判定する代わりに2連結

　　aryOut(1, ix) = aryOut(0, ix) & aryOut(0, ix)

　　'裏返しでの判定用に文字列反転

      　　aryOut(2, ix) = StrReverse(aryOut(1, ix))

End Sub


      '赤玉が隣り合わないルール判定と同一配置判定

Function isRules(ByRef aryOut, ByRef aryIn) As Boolean

　　isRules = False

　　Dim s As String: s = Join(aryIn, "")

　　

　　If s Like "*赤赤*" Then Exit Function

　　If s Like "赤*赤" Then Exit Function

　　

　　Dim i As Long

　　For i = LBound(aryOut, 2) To UBound(aryOut, 2)

      　　　　If InStr(aryOut(1, i), s) > 0 Then Exit Function '輪にした場合の同一配置

      　　　　If InStr(aryOut(2, i), s) > 0 Then Exit Function 'ひっくり返しての同一配置

　　Next

　　

　　isRules = True

      End Function

3色なので3新法で順列を作る方法

ツイッターでこのように指摘を受けました。

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

前出VBAを作成の時には、この方法は面倒だなと思ったのですが、改めて考えてみると、、、
3進法を使って順列作った後に、各色をカウントして対象の時だけ処理すれば良いと気づいたので、
この方法でVBAを作成しました。
順列を作る部分以外は、前出のVBAの部品をほぼそのまま使用しています。
各色の数は、VBA内でマジックナンバーになっていますが、急遽作成ということで。


  
    
      Sub main()

　　Dim i As Long, j As Long, ix As Long

　　Dim base3 As String

　　Dim aryIn(1 To 11) As String

　　Dim aryOut

　　Dim rCnt As Long, wCnt As Long, bCnt As Long

　　

　　For i = 0 To 3 ^ 11 - 1

　　　　base3 = WorksheetFunction.Base(i, 3, 11)

　　　　For j = 1 To Len(base3)

　　　　　　Select Case Mid(base3, j, 1)

　　　　　　　　Case "0": aryIn(j) = "赤"

　　　　　　　　Case "1": aryIn(j) = "白"

　　　　　　　　Case "2": aryIn(j) = "青"

　　　　　　End Select

　　　　Next

　　　　rCnt = getColorCount(aryIn, "赤")

　　　　wCnt = getColorCount(aryIn, "白")

　　　　bCnt = getColorCount(aryIn, "青")

　　　　If rCnt = 4 And wCnt = 2 And bCnt = 5 Then

　　　　　　If isRules(aryOut, aryIn) Then

　　　　　　　　If IsEmpty(aryOut) Then

　　　　　　　　　　ix = 0

　　　　　　　　　　ReDim aryOut(2, ix)

　　　　　　　　Else

　　　　　　　　　　ix = UBound(aryOut, 2) + 1

　　　　　　　　　　ReDim Preserve aryOut(2, ix)

　　　　　　　　End If

　　　　　　　　Call aryIn2Out(aryIn, aryOut, ix)

　　　　　　End If

　　　　End If

　　Next

　　

　　Call ary2sheet(aryOut, ActiveSheet, UBound(aryIn) - LBound(aryIn) + 1)

End Sub


Function getColorCount(ByRef aryIn, ByVal aColor As String) As Long

　　getColorCount = Len(Join(aryIn, "")) - Len(Replace(Join(aryIn, ""), aColor, ""))

End Function


Function isRules(ByRef aryOut, ByRef aryIn) As Boolean

　　isRules = False

　　Dim s As String: s = Join(aryIn, "")

　　

　　If s Like "*赤赤*" Then Exit Function

　　If s Like "赤*赤" Then Exit Function

　　

　　If IsEmpty(aryOut) Then

　　　　isRules = True: Exit Function

　　End If

　　

　　Dim i As Long

　　For i = LBound(aryOut, 2) To UBound(aryOut, 2)

　　　　If InStr(aryOut(1, i), s) > 0 Then Exit Function

　　　　If InStr(aryOut(2, i), s) > 0 Then Exit Function

　　Next

　　

　　isRules = True

      End Function

Sub ary2sheet
Sub aryIn2Out
これらは、前出のVBAと全く同じなので、それをそのままCallしています。

処理時間は数秒で終わります。
さすがに、処理件数が少ないので速いですね。

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

数値変数の値を別の変数を使わずに入れ替える
 Rangeオブジェクトを受け取り"行数,列数"で埋める
 数式の関数の使用回数、関数名を配列で返す
 日付型と通貨型のValueとValue2について
 小文字"abc"を大文字"ABC"に変換する方法
 オブジェクトのByRef、ByVal、Variant
「マクロの登録」で登録できないプロシージャーは?
ジャグ配列から順列を作成する
 シート内の全テーブルを1つに統合
 VBA穴埋め問題「On Error GoToの挙動」
数珠順列（配置に条件付き）を全て出力する

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

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.マクロとは？VBAとは？VBAでできること｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
10.条件分岐（IF）｜VBA入門

ホーム
エクセル全般
ツイッター出題回答
数珠順列（配置に条件付き）を全て出力する

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

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

ツイッター出題回答
数珠順列（配置に条件付き）を全て出力する