数珠順列(配置に条件付き)を全て出力する
ツイッターで出したエクセルVBAの問題です。
赤玉、白玉、青玉
それぞれの個数を決めて、配置に制限を設けた時の全ての配置パターンを出力するという問題です。
出題元のツイート

https://twitter.com/yamaoka_ss/status/1559809556494004224
最後はなんとか正解にたどり着いたようです。

https://twitter.com/yamaoka_ss/status/1559856326854860800
出題ツイート
白玉2個、赤玉4個、青玉5個を数珠つなぎにする。
どの赤玉も隣り合わないように配置するとき、配置パターンを全て出力せよ。
例:赤,青,赤,白,赤,青,赤,青,白,青,青
※今回は白は2個ですよ

https://twitter.com/yamaoka_ss/status/1560536268206772225
やるべきことははっきりしているのだけど、現実的な処理時間に収められるかが問題ですかね。
引用リツイートでの回答

https://twitter.com/yamaoka_ss/status/1560564002932924416
39916800
こんなにあるんだ・・・
総当たりだと厳しいかな、、、
まあPCに頑張ってもらう事にしようwww
今日プログラム書いて答えを出す時間の方が短かったですかね。
というか、白2を手作業では無理ですねwww
あれー、なんか偏ってねなー・・・
そうか、赤の隣に白が来ないパターンは1通りしかないのか・・・うーん、合ってるよね。

赤赤パターンを少し早めに打ち切っているので、全順列よりは少なくしてはいます。
出題者としての解答

https://twitter.com/yamaoka_ss/status/1560921483865903104
単純な順列としては、
FACT(11)=39916800
このくらいの処理なら、最近のPCなら時間はかかっても処理出来ないことも無いだろうと見当をつけて開始です。
全順列を作る方法はいろいろあると思いますが、
再帰処理で配列の順番を入れ替えながら全順列を作るようにしました。
さらに数珠なので輪にしたときに同一となる配置、さらに裏返したときに同じ配置になるパターンを除外します。
これらをどのように判定するかが難しいところですね。
輪にした時の判定をどうするか…
1つずつずらして回転させて判定…それはちょっと処理時間がかかってしまいそうです。
そこで配置パターンを2回繰り返してくっ付けます。
パターン1 & パターン1
この文字列内のどこかにパターン1があれば重複パターンと判定します。
これは単純に文字列を反転させれば良さそうです。
ただし、輪の判定なので2回繰り返した文字列の反転を使います。
1ンータパ & 1ンータパ
この文字列内のどこかにパターン1があれば重複パターンと判定します。
実際の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
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の挙動」
数珠順列(配置に条件付き)を全て出力する
新着記事NEW ・・・新着記事一覧を見る
列全体を指定する時のRangeとColumnsの違い|ツイッター出題回答 (2023-09-24)
シートのActiveXチェックボックスの指定方法|ツイッター出題回答 (2023-09-24)
ByRef引数の型が一致しません。|ツイッター出題回答 (2023-09-22)
シートコピー後のアクティブシートは何か|ツイッター出題回答 (2023-09-19)
Excel関数の引数を省略した場合について|ツイッター出題回答 (2023-09-14)
セル個数を返すRange.CountLargeプロパティとは|VBA技術解説(2023-09-08)
記号を繰り返してグラフ作成(10単位で折り返す)|ツイッター出題回答 (2023-08-28)
シートを削除:不定数のシート名に対応|VBAサンプル集(2023-08-24)
ランクによりボイントを付ける(同順位はポイントを分割)|ツイッター出題回答 (2023-08-22)
OneDrive使用時のThisWorkbook.Pathの扱い方|VBA技術解説(2023-07-26)
アクセスランキング ・・・ ランキング一覧を見る
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コードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。