[[20150702062542]]　『組合せのマクロをお願いします』（中川）　ページの最後に飛ぶ

『組合せのマクロをお願いします』（中川）

お世話になっております。

A列に、0～9の中からランダムに0～5個の数字
B列に、0～9の中からランダムに0～5個の数字
C列に、0～9の中からランダムに0～5個の数字
D列に、0～9の中からランダムに0～5個の数字
が記載されているとします。

A列…5,9
B列…2,3,8
C列…なし
D列…0,1,4,7
といった感じです。数字の重複はありません。
6が入っておりませんが、欠けている数字もあります。

F列に、この中から組合せで3桁の数字を出したく思っています。
同じ列内からは重ならないように、つまり上の例ですと、A列からは5か9かどちらかで、5と9両方は入らないようにしたいです。
場合によってはA～Dの数字が合計3個に満たない場合もありますが、それは出来上がった組合せ数字を羅列する場所（F列）が空白になるものとして処理したいです。
また、3桁は小さい順に並べられているとありがたいです。（534ではなく345に）

関数でなんとかしようとしたのですが挫折しました。
マクロのご教授をいただけますか。（関数の方が助かりますが、おそらく難しいですよね）
どうかよろしくお願い致します。

＜使用 Excel：Excel2010、使用 OS：Windows8 ＞

 0が頭にくるものは3桁と認めるのか認めないのかどちらだろうか？
 （結果を文字列の数字とするのか数値とするのか）
（ねむねむ） 2015/07/02(木) 09:08

 あ、でも頭が0を認めないとすると
 >3桁は小さい順に並べられているとありがたいです。
 とぶつかって「0」が使えなくなるか。
 (0は必ず先頭になるため)
（ねむねむ） 2015/07/02(木) 09:17

説明が足りずにすみません。
おっしゃるとおり、頭が0も3桁となります。結果は数値としたいです。
条件が複数あり煩雑で申し訳ありませんが、よろしくお願い致します。
（中川） 2015/07/02(木) 09:56

　まちがったので、いったん消します。あとで。

（γ） 2015/07/02(木) 20:22

 トライしてみました。
 余り念入りにテストしていないので、間違っていたら失礼。

 Dim dic1 As Object
 Dim dic2 As Object
 Dim p As Long

 Sub test()
     Dim i As Long, j As Long, k As Long
     Dim s As String

     p = 0

     'A～D列のデータを辞書 dic1 に格納
     Call dataset

     ' 書き込み先の初期化
     Sheet1.Columns("F").NumberFormatLocal = "@"
     Sheet1.Columns("F:G").ClearContents

     Set dic2 = CreateObject("Scripting.Dictionary")

     ' すべての組み合わせを作って、チェックし、合格したものを書き出す
     For i = 0 To 7
         For j = i + 1 To 8
             For k = j + 1 To 9
                 s = CStr(i) & CStr(j) & CStr(k)
                 If check(s) Then
                     p = p + 1
                     Sheet1.Cells(p, "F").Value = s
                     Sheet1.Cells(p, "G").Value = CLng(s)
                 End If
             Next
         Next
     Next
 End Sub

 Sub dataset()
     Dim k As Long
     Dim j As Long
     Dim s As String

     Set dic1 = CreateObject("Scripting.Dictionary")
     For k = 1 To 4
         For j = 1 To Sheet1.Cells(Rows.Count, k).End(xlUp).Row
             s = Sheet1.Cells(j, k).Text
             If Len(s) > 0 Then
                 dic1(s) = k
             End If
         Next
     Next
 End Sub

 Function check(s As String) As Boolean
     Dim k As Long
     Dim ss As String
     Dim box As String

     dic2.RemoveAll

     For k = 1 To Len(s)
         ss = Mid(s, k, 1)
         If dic1.exists(ss) Then
             box = CStr(dic1(ss))
             If dic2.exists(box) Then
                 Exit Function
             Else
                 dic2(box) = Empty
             End If
         Else
             Exit Function
         End If
     Next
     check = True

 End Function

（γ） 2015/07/02(木) 20:36

コメント返信：

[ 一覧(最新更新順) ]

[[20150702062542]] 『組合せのマクロをお願いします』（中川） ページの最後に飛ぶ

[[20150702062542]]　『組合せのマクロをお願いします』（中川）　ページの最後に飛ぶ