[[20091010143423]]　『順列』（あつし）　ページの最後に飛ぶ

『順列』（あつし）

 いつもお世話になっています。
 今日は会社のデータをフィルタ設定するために抜き出すデータを作成したいのですが
 よろしくお願いします。
 たとえばアルファベットで始まる３文字の文字を二つ以上の組み合わせを作成したいのです。
 またＡ１２という文字はＡＸＸというものに置き換えたものも必要になります。
 Ａ１２とＢ２３だとすると
 Ａ１２ Ｂ２３
 Ａ１２ ＢＸＸ
 ＡＸＸ ＢＸＸ
 ＡＸＸ Ｂ２３
 Ｂ２３ Ａ１２
 ＢＸＸ Ａ１２
 ＢＸＸ ＡＸＸ
 Ｂ２３ ＡＸＸ
 の８個出てきます。
 これをマクロで自動に出したいのですが・・・

 これを３組の時、４組のときぐらいまで作成したいのですが
 どのようにしていいものかよくわかりません。
 Ａ１セル、Ｂ１セル、Ｃ１セル・・・という具合に
 そこに入っているデータのすべての順列と○ＸＸにしたデータの
 一覧を作成する方法を教えてください。

 新規ブックで試してください。

 標準モジュール（Module1）に

 '====================================================================
 Option Explicit
 Sub test()
    Dim a1() As Variant
    Dim a2() As Variant
    Dim g0 As Long
    Dim rng As Range
    Range("a1").Value = "A12"
    Range("b1").Value = "B23"
    MsgBox "この条件での実行します"

    g0 = Range("a1:b1").Count + 1
    ReDim a1(1 To Range("a1:b1").Count)
    ReDim a2(1 To Range("a1:b1").Count)
    For Each rng In Range("a1:b1")
       Range("a1:b1").Cells(1, g0).Value = Mid(rng.Value, 1, 1) & "xx"
       a2(g0 - Range("a1:b1").Count) = Mid(rng.Value, 1, 1)
       g0 = g0 + 1
    Next
    Call init_permut(Range("a1", Cells(1, Range("a1:b1").Count * 2)), 2)
    g0 = 3
    Do While get_permut(a1()) = 0
       If chk_member(a1(), a2()) Then
          Cells(g0, 1).Value = a1(1)
          Cells(g0, 2).Value = a1(2)
          g0 = g0 + 1
       End If
    Loop
    close_permut
 End Sub
 '====================================================================================
 Function chk_member(c_array1() As Variant, c_array2() As Variant) As Boolean
    Dim g0 As Long
    chk_member = True
    For g0 = LBound(c_array2()) To UBound(c_array2())
        If UBound(Filter(c_array1(), c_array2(g0), , vbBinaryCompare)) <> 0 Then
           chk_member = False
           Exit For
        End If
    Next
 End Function

 別の標準モジュール(Module2)に以前に作成した順列リスト作成モジュール

 '================================================================================
 Option Explicit
    Private p_svn As Long '抜き取り数保存
    Private p_myarray() '順列対象値の配列
    Private p_idx() As Long '配列の各位置のボインタ
 '================================================================================
 Function init_permut(ByVal rng As Range, ByVal seln As Long) As Double
 '順列リストを作成の初期化処理
 'input  rng　順列リスト作成する標本セル範囲
 '       seln 抜き取り数
 'output init_permut---順列数
   On Error Resume Next
    Dim g0 As Long
    Dim crng As Range
    p_svn = seln
    Erase p_myarray()
    Erase p_idx()
    g0 = 1
    ReDim p_myarray(1 To rng.Count)
    For Each crng In rng
      p_myarray(g0) = crng.Value
      g0 = g0 + 1
      Next
    ReDim p_idx(1 To seln)
    For g0 = 1 To UBound(p_idx())
      p_idx(g0) = 1
      Next
    init_permut = WorksheetFunction.Permut(rng.Count, seln)
 End Function
 '================================================================================
 Function get_permut(ans(), Optional ByVal n_cnt As Long = 1) As Long
 'init_permutの指定に基づく順列リストを取得する
 'output  ans()  順列リストを配列で出力する
 '　　　　　　　　予め必要な配列領域は呼び出し側で用意すること
 '　　　　　　　　尚、指定配列の添え字ベースは1とする
 '　　　　get_permut  0　正常に順列リストを取得　1　順列リストはなし
   Dim g0 As Long
   Dim g1 As Long
   Dim retcode As Long
   get_permut = 1
   For g0 = p_idx(n_cnt) To UBound(p_myarray())
       retcode = 0
       For g1 = LBound(p_idx()) To n_cnt - 1
          If p_idx(g1) = g0 Then
             retcode = 1
             Exit For
             End If
          Next g1
       If retcode = 0 Then
          ans(n_cnt) = p_myarray(g0)
          p_idx(n_cnt) = g0
          If n_cnt < UBound(p_idx()) Then
             get_permut = get_permut(ans(), n_cnt + 1)
          Else
             p_idx(n_cnt) = g0 + 1
             get_permut = 0
             End If
          End If
       If get_permut = 0 Then Exit For
       Next g0
   If get_permut = 1 Then
      p_idx(n_cnt) = 1
      End If
 End Function
 '================================================================================
 Sub close_permut()
 '順列リストを作成の終了処理
 '（ファイルだって、Openすれば、クローズするよね）
    Erase p_myarray()
    Erase p_idx()
 End Sub

 これでtestを実行してみてください。

 結果は、A3から表示されます。

 >これを３組の時、４組のときぐらいまで作成したいのですが
 3組の時の結果を投稿してみてください。はっきり、結果がわかりませんので・・・。
 でも、恐らくは、上記のtestの変更で可能かと思います。上記コードを解析して御自分で
 3組の時を作成してみてください。

 ichinose

 面白そうなんでよせてくらはい。＾＾
 Ａ１から右へＡ１２　Ｂ２３　Ｃ１８　Ａ２０　Ｂ２５　Ｃ３０ (文字と数値で）
 てな塩梅にデータが並んでる（幾とおりでも可）としとります。
 　　　　（弥太郎）
 '--------------------------
 Option Explicit
Sub 組み合わせ()
    Dim dic As Object, i As Long, n As Integer, t As Integer, j As Integer
    Dim data As String, a As String, x, y, tbl, ky, ky1
    Set dic = CreateObject("scripting.dictionary")
    tbl = Cells(1, 1).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column)
    With CreateObject("vbscript.regexp")
        .Pattern = "(\D+)(\d+)"
        For n = 1 To UBound(tbl, 2)
            data = StrConv(tbl(1, n), vbNarrow)
            a = Left(tbl(1, n), Len(.Replace(data, "$1")))
            If Not dic.exists(a) Then
                dic(a) = Array(.Replace(data, "$2"))
            Else
                y = dic(a)
                ReDim Preserve y(UBound(y) + 1)
                y(UBound(y)) = .Replace(data, "$2")
                dic(a) = y
                t = IIf(t > UBound(y), t, UBound(y))
            End If
        Next n
    End With
    n = 0
    ReDim x(1 To (UBound(tbl, 2) - t + 1) * UBound(tbl, 2), 1 To 2)
    For Each ky In dic.keys
        For i = 0 To UBound(dic(ky))
            For Each ky1 In dic.keys
                If ky <> ky1 Then
                    For j = 0 To UBound(dic(ky1))
                        n = n + 1
                        x(n, 1) = ky & dic(ky)(i)
                        x(n, 2) = ky1 & dic(ky1)(j)
                    Next j
                End If
            Next ky1
        Next i
    Next ky
    Cells(3, 1).Resize(n, 2) = x
    Set dic = Nothing
 End Sub

 かういう事ではないんでっしゃろか？

 ----
 ありがとうございます。
 返事が遅くなりすいません。
 家ＰＣがネット使えず、会社からの書込み禁止でネットから書き込んでます。
 会社で見て月曜日にマクロは実行しました。
 CHINOSEさんのでできました。
 条件がややうまいこといかなかったのでCHECK＿MEMBERを修正して
 何とかできました。
 弥太郎さんのはなぜかうまくいかないのですがなぜでしょう？
 ？ＸＸに変換しようとしていないのでしょうか？

 う～ん、どういう風に抽出したいのかわかりまへんのんで
 こんな塩梅なんでっか？
 '--------------------------
 Sub 組み合わせ1_2()
    Dim dic As Object, i As Long, n As Integer, t As Integer, j As Integer
    Dim data As String, a As String, u As Integer, x, y, tbl, ky, ky1, b
    Set dic = CreateObject("scripting.dictionary")
    tbl = Cells(1, 1).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column)
    With CreateObject("vbscript.regexp")
        .Pattern = "(\D+)(\d+)"
        For n = 1 To UBound(tbl, 2)
            data = StrConv(tbl(1, n), vbNarrow)
            a = Left(tbl(1, n), Len(.Replace(data, "$1")))
            u = IIf(InStr(data, "×"), InStr(data, "×"), InStr(data, "X"))
            If u > 0 Then
                a = Left(tbl(1, n), u - 1)
                b = Right(data, Len(data) - (u - 1))
            Else
                a = Left(tbl(1, n), Len(.Replace(data, "$1")))
                b = .Replace(data, "$2")
            End If
            If Not dic.exists(a) Then
                dic(a) = Array(a & b)
            Else
                y = dic(a)
                ReDim Preserve y(UBound(y) + 1)
                y(UBound(y)) = a & b
                dic(a) = y
            End If
        Next n
    End With
    n = 0
    ReDim x(1 To (UBound(tbl, 2)) * UBound(tbl, 2), 1 To 2)
    For Each ky In dic.keys
        For i = 0 To UBound(dic(ky))
            For Each ky1 In dic.keys
                If ky <> ky1 Then
                    For j = 0 To UBound(dic(ky1))
                        n = n + 1
                        x(n, 1) = dic(ky)(i)
                        x(n, 2) = dic(ky1)(j)
                    Next j
                End If
            Next ky1
        Next i
    Next ky
    Cells(3, 1).Resize(n, 2) = x
    Set dic = Nothing
 End Sub
 '------------------------------
 それともこっちでっか？
 　　　　（弥太郎）
 '-----------------------------
 Sub 組み合わせ2_2()
    Dim dic As Object, dic1 As Object, i As Integer, n As Integer, t As Integer
    Dim j As Integer, data As String, a As String, x, y, tbl, ky, ky1, b
    Set dic = CreateObject("scripting.dictionary")
    Set dic1 = CreateObject("scripting.dictionary")
    tbl = Cells(1, 1).Resize(, Cells(1, Columns.Count).End(xlToLeft).Column)
    With CreateObject("vbscript.regexp")
        .Pattern = "(\D+)(\d+)"
        For n = 1 To UBound(tbl, 2)
            data = StrConv(tbl(1, n), vbNarrow)
            u = IIf(InStr(data, "×"), InStr(data, "×"), InStr(data, "X"))
            If u > 0 Then
                a = Left(tbl(1, n), u - 1)
                b = Right(data, Len(data) - (u - 1))
            Else
                a = Left(tbl(1, n), Len(.Replace(data, "$1")))
                b = .Replace(data, "$2")
            End If
            If Not dic.exists(a) Then
                dic(a) = Array(a & b)
            Else
                If Not dic1.exists(a & b) Then
                    y = dic(a)
                    ReDim Preserve y(UBound(y) + 1)
                    y(UBound(y)) = a & b
                    dic(a) = y
                    dic1(y(UBound(y))) = Empty
                    i = IIf(i > UBound(y) + 1, i, UBound(y) + 1)
                End If
            End If
        Next n
        ReDim x(1 To IIf(i = 0, 1, i) * dic.Count, 1 To UBound(tbl, 2))
        For n = 1 To UBound(tbl, 2)
            t = 0
            data = StrConv(tbl(1, n), vbNarrow)
            u = IIf(InStr(data, "×"), InStr(data, "×"), InStr(data, "X"))
            If u > 0 Then
                a = Left(tbl(1, n), u - 1)
            Else
                a = Left(tbl(1, n), Len(.Replace(data, "$1")))
            End If
            For Each ky In dic.keys
                If ky <> a Then
                    For j = 0 To UBound(dic(ky))
                        t = t + 1
                        x(t, n) = dic(ky)(j)
                    Next j
                End If
            Next ky
        Next n
    End With
    Cells(3, 1).Resize(UBound(x, 1), UBound(tbl, 2)) = x
    Set dic = Nothing
    Set dic1 = Nothing
 End Sub

 弥太郎さんありがとうございます。
 ＮＥＴカフェにエクセルがないので返信来週になってしまいますが
 試してみます。 ありがとうございます。
 （あつし）

コメント返信：

[ 一覧(最新更新順) ]

[[20091010143423]] 『順列』（あつし） ページの最後に飛ぶ

[[20091010143423]]　『順列』（あつし）　ページの最後に飛ぶ