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

ExcelマクロVBAとエクセル関数についての私的雑感
最終更新日:2022-08-21

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


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


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


出題元のツイート

Excel エクセルVBA問題 数珠順列
https://twitter.com/yamaoka_ss/status/1559809556494004224


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


Excel エクセルVBA問題 数珠順列
https://twitter.com/yamaoka_ss/status/1559856326854860800


出題ツイート

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


Excel エクセルVBA問題 数珠順列
https://twitter.com/yamaoka_ss/status/1560536268206772225


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


引用リツイートでの回答

引用リツイート


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

Excel エクセルVBA問題 数珠順列
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
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

Excel エクセルVBA問題 数珠順列


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

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

https://twitter.com/yamaoka_ss/status/1560930969812873221
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の挙動」
数珠順列(配置に条件付き)を全て出力する


新着記事NEW ・・・新着記事一覧を見る

スピルとは:スピル基礎から応用までの問題集|エクセル入門(2022-09-26)
リーグ表に対戦番号を振る|ツイッター出題回答 (2022-09-23)
脱字メーカー(文字列から1文字削除)|ツイッター出題回答 (2022-09-05)
スピルとは:旧関数でスピルを使う問題と解説|エクセル入門(2022-09-21)
スピルとは:スピル入門の問題と解説|エクセル入門(2022-09-16)
直積(クロス結合、交差結合)とピボット解除|エクセル入門(2022-09-08)
脱字メーカー(文字列から1文字削除)|ツイッター出題回答 (2022-09-05)
【VBA学習のお勧めコース】|VBA入門(2022-09-02)
振込手数料を先方負担にした時の振込金額と手数料の算出|ツイッター出題回答 (2022-09-01)
構成比を合計しても100%にならないと言われた…|ツイッター出題回答 (2022-09-01)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.Excelショートカットキー一覧|Excelリファレンス
7.並べ替え(Sort)|VBA入門
8.マクロって何?VBAって何?|VBA入門
9.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
10.エクセルVBAでのシート指定方法|VBA技術解説




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


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



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