[[20201224104822]]　『組み合わせパターンを自動で作りたい』（マルコ）　ページの最後に飛ぶ

『組み合わせパターンを自動で作りたい』（マルコ）

アルファベットが重複しないABCDの組み合わせパターン16種類を表にしたいのですが、DCBA、BACDなど手入力ではなく自動で作成する方法はありますか？
アルファベットは一つのセルに１つで作成したいです。
何か方法があればご教授をお願いしますm(__)m

＜使用 Excel：Office365、使用 OS：Windows10 ＞

 こちらは参考になりますか？
https://excel-ubara.com/excelvba5/EXCELVBA264.html
（稲葉） 2020/12/24(木) 12:06

稲葉さんありがとうございます！

素人の私には難しすぎて厳しいです・・・orz
教えて頂いたページの「VBAをコピー」を押してコピーしてエクセルのマクロに貼り付けてみたんですが、SUBまたはFunctionが定義しておりませんみたいなエラーが出ます・・・。

このVBAというものを使わないと難しいでしょうか？＾＾：

（マルコ） 2020/12/24(木) 16:07

 稲葉さんのご紹介されているページのコードをまとめてみました。
 このコードを、まるっと標準モジュールにコピペしてもらって、[test]を実行してください。
 こちらでは動作を確認していますが、どうでしょう？(^^;

 Option Explicit

Sub test()

    Dim AryIn
    Dim AryOut

    'AryInに"A"～"D"のアルファベットをセット
    AryIn = Array("A", "B", "C", "D")

    '[permutation]を実行
    Call permutation(AryIn, AryOut)

    'アクティブなシートの
    With ActiveSheet
        '全セルの値を消去
        .Cells.ClearContents
        '[A1]セルを起点に結果を書き出し
        .Range("A1").Resize(UBound(AryOut, 2) + 1, UBound(AryOut, 1) + 1) = _
            WorksheetFunction.Transpose(AryOut)
    End With

End Sub

Public Sub permutation(ByRef AryIn, ByRef AryOut, Optional ByVal i As Long = 0)

    Dim j As Long
    Dim ix As Long
    Dim sTemp
    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
            '再帰処理、開始位置を+1
            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

 それにしても、便利ですねこれ(^^)

（虎） 2020/12/24(木) 16:29

 むかし作った小道具が残ってたので、使えれば・・・
 16種類じゃなくて階乗だから4!＝4*3*2*1ですよね？

 クラスモジュールを追加して、オブジェクト名をcls_nPnとする
    Option Explicit
    Private n         As Long
    Private k         As Long
    Private P()       As Long
    Private ans()
    Private str()
    Private dlm       As String
    Private OpType    As clsOutType
    Private App       As Application
    Public Enum clsOutType
       ToArray = 1
       ToString = 2
    End Enum
    Private Sub Class_Initialize()
        Set App = Application
    End Sub
    Public Property Get Count() As Variant
        Count = n
    End Property
    Public Property Get Items() As Variant
        Items = ans
    End Property
    Public Property Let Delimiter(ByVal strDlm As String)
        dlm = strDlm
    End Property

    '_/_/_/_/_/1から始まる配列に直す_/_/_/_/_/
    Sub Add(ary As Variant, OutputType As clsOutType)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
        Dim x
        Dim i As Long
        Dim DIC As Object
        Set DIC = CreateObject("Scripting.Dictionary")
        For Each x In ary
            If Not DIC.exists(x) Then DIC.Add x, ""
        Next x
        str = App.Transpose(App.Transpose(DIC.keys))
        n = DIC.Count

        '#1-nの数値をPに入れる
        ReDim P(1 To n)
        For i = 1 To n
            P(i) = i
        Next i
        OpType = OutputType
        '#回答の入れ物を作る
        If OpType = clsOutType.ToArray Then
            ReDim ans(1 To App.WorksheetFunction.Fact(n), 1 To n)
        Else
            ReDim ans(1 To App.WorksheetFunction.Fact(n))
        End If

        k = 1

        '#順列組み合わせ作成
        Perm 1
    End Sub

    '_/_/_/_/_/順列作成プログラム_/_/_/_/_/
    Private Sub Perm(ByRef A As Long)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
        Dim B As Long
        If A < n Then
            For B = A To n
                Swap P(A), P(B)
                Perm A + 1
                Swap P(A), P(B)
            Next B
        Else
            If OpType = clsOutType.ToArray Then
                For B = 1 To n
                    ans(k, B) = str(P(B))
                Next B
            Else
                For B = 1 To n
                    ans(k) = ans(k) & dlm & str(P(B))
                Next B
                ans(k) = Mid(ans(k), Len(dlm) + 1)
            End If
            k = k + 1
        End If
    End Sub

    '_/_/_/_/_/順列作成サブルーチン_/_/_/_/_/
    Private Sub Swap(ByRef A As Long, ByRef B As Long)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
        Dim t As Long
        '#配列の位置を入れ帰る
        t = A
        A = B
        B = t
    End Sub

 標準モジュールに入れて、実行するとアクティブシートのA1～行方向に出力
    Sub 呼び出し例()
        Dim buf As Variant
        With New cls_nPn
            .Delimiter = ""
            .Add Array("A", "B", "C", "D"), ToString
            buf = .Items
        End With
        Range("A1").Resize(UBound(buf)).Value = Application.Transpose(buf)
    End Sub

 出力結果
     |[A] 
 [1] |ABCD
 [2] |ABDC
 [3] |ACBD
 [4] |ACDB
 [5] |ADCB
 [6] |ADBC
 [7] |BACD
 [8] |BADC
 [9] |BCAD
 [10]|BCDA
 [11]|BDCA
 [12]|BDAC
 [13]|CBAD
 [14]|CBDA
 [15]|CABD
 [16]|CADB
 [17]|CDAB
 [18]|CDBA
 [19]|DBCA
 [20]|DBAC
 [21]|DCBA
 [22]|DCAB
 [23]|DACB
 [24]|DABC

（稲葉） 2020/12/24(木) 18:48

虎さん、稲葉さん年末のお忙しいところ、ありがとうございます！

動きました！

助かりました！！！m(__)m

（マルコ） 2020/12/25(金) 10:08

コメント返信：

[ 一覧(最新更新順) ]

[[20201224104822]] 『組み合わせパターンを自動で作りたい』（マルコ） ページの最後に飛ぶ

[[20201224104822]]　『組み合わせパターンを自動で作りたい』（マルコ）　ページの最後に飛ぶ