[[20130901093710]]　『組み合わせのパターン分類』（ひろこ）　ページの最後に飛ぶ

『組み合わせのパターン分類』（ひろこ）

 おせわになります。
 エクセルで以下のような組み合わせ表があった場合に、行方向の組み合わせの種類をパターン分類化したいです。
 どのような方法で、選別したらよろしいでしょうか？
 (データ)
 　A B C D E
 1 3 3 1 2 3  
 2 1 3 3 2 3   
 3 1 1 2 2 2 
 4 3 3 1 2 2 
 5 1 1 2 2 2 
 6 3 3 1 2 3

 (以下のように分類がしたいです)
 　A B C D E
 1 3 3 1 2 3   ←パタンA  
 2 1 3 3 2 3   ←パタンB 
 3 1 1 2 2 2   ←パタンC 
 4 3 3 1 2 2   ←パタンD 
 5 1 1 2 2 2   ←パタンC
 6 3 3 1 2 3   ←パタンA

 もう一つ、パタン分類が違えばそれを別タグにリスト化(コピー)する方法も教えてくださいませんか？
 　A B C D E
 1 3 3 1 2 3   ←パタンA  ⇒ タグAの1行目へ
 2 1 3 3 2 3   ←パタンB  ⇒ タグBの1行目へ
 3 1 1 2 2 2   ←パタンC  ⇒ タグCの1行目へ
 4 3 3 1 2 2   ←パタンD  ⇒ タグDの1行目へ
 5 1 1 2 2 2   ←パタンC  ⇒ タグCの2行目へ
 6 3 3 1 2 3   ←パタンA  ⇒ タグAの2行目へ

 聞いてばかりですみません。

 1,2,3の数字すべての組み合わせは　　３×３×３×３×３＝２４３通り　が考えられますが、
 提示された組み合わせのみでよいのでしょうか。

 データがA1からということで

 Sub test()
     Dim a, i As Long, ii As Long, txt As String
     With Cells(1).CurrentRegion
         a = .Value
         With .Parent.Cells
             .ClearContents
             .UnMerge
         End With
         .Value = a
         With CreateObject("Scripting.Dictionary")
             For i = 1 To UBound(a, 1)
                 For ii = 1 To UBound(a, 2)
                     txt = txt & Chr(2) & a(i, ii)
                 Next
                 If Not .exists(txt) Then
                     Set .Item(txt) = CreateObject("System.Collections.ArrayList")
                 End If
                 .Item(txt).Add Application.Index(a, i, 0)
                 txt = ""
             Next
             For i = 0 To .Count - 1
                 With Cells(1, i * UBound(a, 2) + UBound(a, 2) + 2).Resize(, UBound(a, 2))
                     .Merge
                     .HorizontalAlignment = xlCenter
                     .Value = "Pattern " & Chr(i + 65)
                 End With
                 Cells(2, i * UBound(a, 2) + UBound(a, 2) + 2).Resize(.items()(i).Count, UBound(a, 2)).Value = _
                 Application.Transpose(Application.Transpose(.items()(i).ToArray))
             Next
         End With
         .Parent.Columns.AutoFit
     End With
 End Sub

 (seiya)

seiyaさん、お忙しい中ご回答ありがとうございます。
ヒントを頂戴すれば、あとは何とか出来ると思っていましたが、とても難しいことが分かりました。
更に2つお聞きして良いでしょうか？
A列に1列足して、B1からF6までを分類する場合、
スクリプト後半のリスト化する箇所にA列もコピーするには、どうしたらよろしいでしょうか？出来ましたらpatternとpatternの間も1列空けたいです。

 　A B C D E F
 1 海 3 3 1 2 3  
 2 山 1 3 3 2 3   
 3 川 1 1 2 2 2 
 4 谷 3 3 1 2 2 
 5 森 1 1 2 2 2 
 6 林 3 3 1 2 3

(ひろこ）

 3箇所(実際は2箇所)変えるだけ

 Sub test()
     Dim a, i As Long, ii As Long, txt As String
     With Cells(1).CurrentRegion
         a = .Value
         With .Parent.Cells
             .ClearContents
             .UnMerge
         End With
         .Value = a
         With CreateObject("Scripting.Dictionary")
             For i = 1 To UBound(a, 1)
                 For ii = 2 To UBound(a, 2)   '<---- ここ
                     txt = txt & Chr(2) & a(i, ii)
                 Next
                 If Not .exists(txt) Then
                     Set .Item(txt) = CreateObject("System.Collections.ArrayList")
                 End If
                 .Item(txt).Add Application.Index(a, i, 0)
                 txt = ""
             Next 
             For i = 0 To .Count - 1     ' ↓ここと、End With の後の + i
                 With Cells(1, i * UBound(a, 2) + UBound(a, 2) + 2 + i).Resize(, UBound(a, 2))
                     .Merge
                     .HorizontalAlignment = xlCenter
                     .Value = "Pattern " & Chr(i + 65)
                 End With
                 Cells(2, i * UBound(a, 2) + UBound(a, 2) + 2 + i).Resize(.items()(i).Count, UBound(a, 2)).Value = _
                 Application.Transpose(Application.Transpose(.items()(i).ToArray))
             Next
         End With
         .Parent.Columns.AutoFit
     End With
 End Sub

 (seiya)

(seiya)さんありがとうございます。
大変助かりました。頂いたヒントをもとに頑張ってみます。

(ひろこ）

コメント返信：

[ 一覧(最新更新順) ]

[[20130901093710]] 『組み合わせのパターン分類』（ひろこ） ページの最後に飛ぶ

[[20130901093710]]　『組み合わせのパターン分類』（ひろこ）　ページの最後に飛ぶ