[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『条件のある組合せをVBAで作成、表示を』（困困）
単純な組合せ、例えば８つの数字から６つ取り出して組合せなどはFAQなどで、 参考にして何とかできるのですが、グループの中で一緒に組み合わせることのできない数値, 文字があるような組合せを作るのに、困っています。
表-1・・・(表-1,2のA〜Mは列、1〜41は行番号）
A B C D E F G H I J K L M 1 1 2 3 4 5 6 7 8 9 a b c 2 * 0 0 0 1 0 0 0 0 1 0 0 0 3 * 1 0 0 1 1 1 0 0 1 0 0 0 4 * 1 1 0 0 0 0 0 0 0 0 0 0 5 * 0 0 1 0 0 0 0 0 1 0 1 1 6 * 0 0 0 0 0 0 0 0 1 1 0 0 7 * 0 0 0 1 0 0 0 0 0 0 0 0 8 * 0 0 0 0 0 0 0 0 1 1 0 0 9 * 0 0 0 0 0 0 0 0 1 1 0 0 10 * 0 0 0 1 0 0 0 0 1 0 0 0 11 * 0 0 0 1 0 0 0 0 1 0 0 0 12 * 0 0 0 0 0 0 0 0 0 0 0 0 13 * 0 0 1 0 0 0 0 0 0 0 1 0 14 * 1 0 0 0 0 0 0 0 0 0 0 0 15 * 0 0 1 0 0 0 0 0 0 0 0 0 16 * 0 0 0 0 0 0 0 0 1 0 0 0 17 * 0 0 0 0 0 0 1 1 1 1 0 0 18 * 0 1 0 0 0 0 0 0 0 0 0 0 19 * 0 0 0 0 0 0 0 0 1 1 0 0 20 * 0 0 0 0 0 0 0 0 1 1 0 0 21 * 0 0 0 0 0 0 1 0 1 1 0 0 22 * 0 0 0 0 0 0 1 0 1 1 0 0 23 * 0 0 0 0 0 0 1 0 1 1 0 0 24 * 0 1 0 0 0 0 0 0 0 0 0 0 表-1はA列のいろんな条件*に合致したら、[1],しなければ[0]で表しています。 同じ行に[1]があるﾌｨｰﾙﾄﾞの見出しの値は同時には組み合わすことが出来ません。 表-1を元に組合せ可能な数値を取り出したのが、表-２です。
表-2の説明です。セル（B30)には式=IF(SUMPRODUCT(B2:B24*C2:C24)>=1,"",ﾌｨｰﾙﾄﾞ見出しの値）→結果空白で[1]とは組合せできません。 他のセルも同様に、一緒に組合せの可否判定を行った表です。 組合せは、A列を基準として、その列の数値（文字）による組合せを求め、表示したいです。 行30は[1]を基点として、[1]と[3,7,8,a,b.c]の7文字で最も多くの取り出せた組合せを、求めたいのですが [3]を組み合わせると、[b,c]は組合せできません。また、[7]を組み込むと同様に [8,a]が組み合わせません。 結果[1,3,7]、[1,3,8]、[1,3,a]、[1,7,b]、[1,7,c]、[1,8,b]、[1,8,c]、[1,a.b]、[1,a.c]の9通りが出来ると思います。 [2]を基点にすると[2,3,4,7],[2,3,4,8],[2,3,4,a]・・・・・・以降、[3],[4],[5]・・・・と処理します。 ただし、最小の組合せを、[a,b,ｃ]のように３つ以上で作成です。
A B C D E F G H I J K L M 29 1 2 3 4 5 6 7 8 9 a b c 30 1 3 7 8 a b c 31 2 3 4 5 6 7 8 9 a b c 32 3 4 5 6 7 8 a 33 4 7 8 a b c 34 5 7 8 a b c 35 6 7 8 a b c 36 7 b c 37 8 b c 38 9 39 a b c 40 b 41 c いろいろ、長々と説明しましたが理解していただけたでしょうか。 なお、表-1の前に元表があり、条件が変わります。(組合せの可否が変わる） VBAに精通されている皆様よろしくお願いいたします。
折角ご丁寧な表を呈示なされとりますのに、組合せの基準が理解でけないからレスが つかないんではないでせうか？ [1,3,7]、[1,3,8]、[1,3,a]、[1,3,b]、[1,3,c]、[1,7,8]、[1,7,a]、[1,7,b]、 [1,7,c]、[1,8,a]、[1,8,b]、[1,8,c]、[1,a,b]、[1,a,c]、[1,b,c] 1を基点やと↑のようになると思うんですが・・・。 2が基点の組合せにもその疑問がのこりますし、４個の組合せがどうしてなのかも 一向にわかりまへん。
VBAに精通していなくても、なんだか規則性がないように見受けられますけど、それが しだけが理解でけてないんでっしゃろか？ （弥太郎）
説明を加えます。
行29は見出しの行です。[1,2,3,4,5,6,7,8,9,a,b,c]12の文字があります。 一種の星取表のようなものと理解してください。
表の見方ですが、行と列の交点のセルで、組み合わせが可能か出来ないかを判断します。
下記行ごとにある数字、文字で組み合わせを作りたいのです。（基準の1つ前の文字は含まない。[2]の場合[1]）
30行は[1]と[3,7,8,a,b.c]・・・・・・・・・・・[1]は[2,4,5,6,9]とは組み合わせできない 31行は[2]と[3,4,5,6,7,8,9,a,b.c]・・・・・・・[2]は[1]とは組み合わせできない 32行は[3]と[4,5,6,7,8,a]・・・・・・・・・・・[3]は[9,b,c]とは組み合わせできない 33行は[4]と[7,8,a,b.c]・・・・・・・・・・・・[4][は5,6,9]とは組み合わせできない 34行は[5]と[7,8,a,b.c]・・・・・・・・・・・・[5]は[6,9]とは組み合わせできない 35行は[6]と[7,8,a,b.c]・・・・・・・・・・・・[6]は[9]とは組み合わせできない 36行は[7]と[b.c]・・・・・・・・・・・・・・・[7]は[8,9,a]とは組み合わせできない 37行は[8]と[b.c]・・・・・・・・・・・・・・・[8]は[9,a]とは組み合わせできない 38行は[9]だけで組み合わせなし、現在のところ36行目以降は組み合わせはあっても1つだけ。
疑問の件ですが・・・・
折角ご丁寧な表を呈示なされとりますのに、組合せの基準が理解でけないからレスが
つかないんではないでせうか？ [1,3,7]、[1,3,8]、[1,3,a]、[1,3,b]、[1,3,c]、[1,7,8]、[1,7,a]、[1,7,b]、 [1,7,c]、[1,8,a]、[1,8,b]、[1,8,c]、[1,a,b]、[1,a,c]、[1,b,c] 1を基点やと↑のようになると思うんですが・・・。 2が基点の組合せにもその疑問がのこりますし、４個の組合せがどうしてなのかも 一向にわかりまへん。
上記、弥太郎さんの疑問に対する説明です。
[1]と[3,7,8,a,b.c]の組み合わせで、組み合わせの中に[3]があると、32行の[3]と[4,5,6,7,8,a]は組み合わせできますが、 [b][c]とは一緒に組み合わせません。[1,3,b]、[1,3,c] ←b,cとの組み合わせなし。 [1,b,c]]、[1,8,a]なども同様
31行の[2]と[3,4,5,6,7,8,9,a,b.c]の組み合わせは下記のようになります。 全部組合すと[2,3,4,5,6,7,8,9,a,b,c]ところが、[3]と組み合わせられない[9][b][c]を除くと[2,3,4,5,6,7,8,a] の組み合わせが出来ますが、[4]が組み合わせに含まれると、[4]は[7,8,a,b.c]と組み合わせできるが[5,6,9]と組めない為、 [5,6,9]を除いた[2,3,4,7,8,a]になります。 さらに[2,3,4,7,8,a]も、[7]が[8][a]と組めないため、[2,3,4,7]になります。 同様に、[2,3,4,5,6,7,8,9,a,b,c]から、[3]を除くと、[2,4,5,6,7,8,9,a,b,c]で、、[4]は[5,6,9]と組めない為 [2,4,7,8,a,b,c]さらに、[7]が[8][a]と組めないため [2,4,7,b,c]さらに[b]と[c]は組めないため [2,4,7,b]ができる。 このようにして作成していくと[2]の組み合わせは下記のようになります。 [2,3,4,7],[2,3,4,8],[2,3,4,a],[2,3,5,7],[2,3,5,8],[2,3,5,a],[2,3,6,7],[2,3,6,8],[2,3,7] [2,3,8],[2,3,a],[2,4,7,b],[2,4,7,b],[2,4,7,c],[2,4,8,b],[2,4,8,c],[2,4,a,b],[2,4,a,c] [2,5,7,b],[2,5,7,c],[2,5,8,b],[2,5,8,c],[2,5,a,b],[2,5,a,c],[2,6,7,b],[2,6,7,c],[2,6,8,b] [2,6,8,c],[2,6,a,b],[2,6,9,c]････間違いがあるかも知れませんが
ちなみに[3]の組み合わせは下記のようになります。
[3,4,7],[3,4,8],3,5,7],[3,6,7]の4通り。
[4]の組み合わせは,[4,7,b],[4,7,c],[4,8,b],[4,8,c],[4,a,b],[4,a,c]
[5]の組み合わせは,[5,7,b],[5,7,c],[5,8,b],[5,8,c],[5,a,b],[5,a,c]
[6]の組み合わせは,[6,7,b],[6,7,c],[6,8,b],[6,8,c],[6,a,b],[6,a,c]
また、ごちゃごちゃと書きましたが理解されたでしょうか。 これまで表-2までは、関数で作成していましたが、組み合わせは手作業で行っていました。 なんとか、自動で行いたいと思ってておりますのでよろしくお願いします。
自分がわからなかったところを聞いてみたいと思います。 今現在よくわかっていないので聞いたところで答えられるわけではございませんが、レスがつくようにまとめられたらと考えております。 (1)「いろんな条件*」 とは？
(2) 「一桁目」が[1]だとするならば [1]と組合せができる数字は[378abc]が二桁目になる もし「2桁目」が[3]ならば [3]と組合せができる[45678a]が「3桁目」になる もしくは、[1][3]と組合せることができる[78a]のみ「3桁目」になることができるのでしょうか
(たかなし)
質問（1）について 「いろんな条件」と書きましたが、条件は1つだけです。 組み合わせた文字（数値）によって、組合すことが出来ない文字が出てくるのを判断します。
質問（2）についてです。 [1][3]と組合せることができる[78a]のみ「3桁目」になることができるのでしょうか ↑ ↑ たかなし様、まさしくその通りです。3桁目が[7]の場合、[7]に、[8],[a]は組合すことが出来 ない。表-1で[7][8]を=IF(SUMPRODUCT(H2:H24*I2:K24)>=1,"不可",8)、同じく[a]は(H2:H24*K:K2:K24)>=1 結果は[1,3,7]です。
また、表-1は組み合わせの可否判定に使用されるかと思い掲示しました。 それにしても、私本当に適切に表現出来ませんで・・・・スミマセン！ （困困）
3つまでが思考の限界です。。。orz
4つ以上は他の方のレスをお待ちください。
Sub KomaGoma()
Dim dic As Object, ky
Dim tbl, x, i As Long, ii As Long, iii As Long
tbl = Range("A29:M41").Value
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tbl, 1)
ReDim x(UBound(tbl, 2) - 2)
For ii = 2 To UBound(tbl, 2)
x(ii - 2) = tbl(i, ii)
Next
dic(CStr(tbl(i, 1))) = WorksheetFunction.Trim(Join(x))
Next
ReDim tbl(1 To 3, 1 To 1)
For Each ky In dic.Keys
x = Split(dic(ky))
For i = 0 To UBound(x) - 1
For ii = i + 1 To UBound(x)
If InStr(1, dic(x(i)), x(ii)) > 0 Then
iii = iii + 1
tbl(1, iii) = ky
tbl(2, iii) = x(i)
tbl(3, iii) = x(ii)
ReDim Preserve tbl(1 To 3, 1 To UBound(tbl, 2) + 1)
End If
Next
Next
Next
Range("A43:C" & Rows.Count).ClearContents
Range("A43").Resize(UBound(tbl, 2), 3).Value = Application.Transpose(tbl)
End Sub
(ROUGE)
流石せんぱい。
よくぞ理解しなさったなぁ。＾＾
それがし、まだ充分理解してないんですけど、まぁ下手な鉄砲も数撃ちゃ当たるを頼り
に。
一応４個の組合せまで組み込んでありますけど、検証はお任せします。
（弥太郎）
'----------------------------
Sub 困困()
Dim rng As Range, i As Long, n As Integer, m As Integer, tbl, x(), y(), z
Dim u As Integer, j As Integer, t As Integer, flg As Boolean, get_row1, get_row2
Set rng = Range("a29:m41")
tbl = rng.Value
ReDim z(1 To UBound(tbl, 1) - 1, 1 To 1)
For i = 2 To UBound(tbl, 1)
u = 0
j = 0
If WorksheetFunction.CountBlank(rng(i, 1).Resize(, 13)) < 12 Then
ReDim Preserve x(j)
x(j) = "[" & tbl(i, 1)
j = j + 1
For n = i + 1 To UBound(tbl, 2) - 1
If tbl(i, n) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, n)
j = j + 1
get_row1 = Application.Match(tbl(i, n), rng(1, 1).Resize(UBound(tbl, 1)))
For m = n + 1 To UBound(tbl, 2)
If tbl(i, m) <> "" And tbl(get_row1, m) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, m) & "]"
ReDim Preserve y(u)
y(u) = Join(x, ",")
j = j + 1
get_row2 = Application.Match(tbl(i, m), rng(1, 1).Resize(UBound(tbl, 1)))
For t = m + 1 To UBound(tbl, 2)
If tbl(i, t) <> "" And tbl(get_row1, t) <> "" And _
tbl(get_row2, t) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, t) & "]"
flg = True
ReDim Preserve y(u)
y(u) = Join(x, ",")
y(u) = Replace(y(u), "]", "") & "]"
u = u + 1
flg = True
End If
Next t
u = IIf(flg, u, u + 1)
j = 2
flg = False
End If
Next m
End If
j = 1
Next n
End If
If u > 0 Then z(i - 1, 1) = Join(y, ",")
Next i
rng(1, 13).Offset(, 1).Resize(UBound(z, 1)) = z
End Sub
ありがとうございます。私の拙い説明で良くぞ理解していただけました。
（弥太郎）さんのコードで無事出来ました。
ただし、わたくしめがまだ理解できておりません。これからじっくりコードを拝見して理解したいと思います。 それにしても凄いです。私はもうすぐ60歳になりますが、これから理解を深め皆さんの影が踏める位置 まで少しでも近づけるよう努力したいと感じています。 まだ、理解できていませんが、これからコードをじっくりと理解していきたいと思います。 （弥太郎）さん、（ROUGE)さん、（たかなし）さん、本当にありがとうございました。 （弥太郎）さんのコードを理解して、組合せ1つづつセルに出すようにしたいと思います。 また、皆さんに理解していただけるよう、しっかりした文章が必要と感じました。
（困困）
>組合せ1つづつセルに出すようにしたいと思います。 そうでしたか。 それなら別バージョンを掲載しときますワ。 [ ] が不要の際にはそちらで解決してくらはい。
>また、皆さんに理解していただけるよう、しっかりした文章が必要と感じました。
いや、この作業を文章で表現するのは至難の業。
それがし、３０回は読み直しました。＾＾
（弥太郎）
''''''''''''''''''''''''''''
Sub 困困NewVer()
Dim rng As Range, i As Long, n As Integer, m As Integer, d As Integer, tbl, x(), y
Dim u As Integer, j As Integer, t As Integer, flg As Boolean, get_row1, get_row2
Set rng = Range("a29:m41")
tbl = rng.Value
ReDim y(1 To UBound(tbl, 1), 1 To Excel.Columns.Count)
For i = 2 To UBound(tbl, 1)
u = 1
j = 0
If WorksheetFunction.CountBlank(rng(i, 1).Resize(, 13)) < 12 Then
ReDim Preserve x(j)
x(j) = "[" & tbl(i, 1)
j = j + 1
For n = i + 1 To UBound(tbl, 2) - 1
If tbl(i, n) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, n)
j = j + 1
get_row1 = Application.Match(tbl(i, n), rng(1, 1).Resize(UBound(tbl, 1)))
For m = n + 1 To UBound(tbl, 2)
If tbl(i, m) <> "" And tbl(get_row1, m) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, m) & "]"
y(i - 1, u) = Join(x, ",")
j = j + 1
get_row2 = Application.Match(tbl(i, m), rng(1, 1).Resize(UBound(tbl, 1)))
For t = m + 1 To UBound(tbl, 2)
If tbl(i, t) <> "" And tbl(get_row1, t) <> "" And _
tbl(get_row2, t) <> "" Then
ReDim Preserve x(j)
x(j) = tbl(i, t) & "]"
flg = True
y(i - 1, u) = Join(x, ",")
y(i - 1, u) = Replace(y(i - 1, u), "]", "") & "]"
u = u + 1
flg = True
End If
Next t
u = IIf(flg, u, u + 1)
j = 2
flg = False
End If
Next m
End If
j = 1
Next n
End If
d = IIf(u > d, u, d)
Next i
rng(1, 13).Offset(, 1).Resize(UBound(tbl, 1), d) = y
End Sub
4つ以上にも対応できるように改良してみました。
(ROUGE)
'----
Sub KomaGoma_Ver2()
Dim dic As Object
Dim tbl, x, ky
Dim i As Long, ii As Long
tbl = Range("A29:M41").Value
Set dic = CreateObject("Scripting.Dictionary")
ReDim x(2 To UBound(tbl, 2))
For i = 2 To UBound(tbl, 1)
For ii = 2 To UBound(tbl, 2)
x(ii) = tbl(i, ii)
Next
dic(CStr(tbl(i, 1))) = WorksheetFunction.Trim(Join(x))
Next
ReDim x(0)
For Each ky In dic.Keys
Check_Duplication x, dic, ky
Next
Range("A43:A" & Rows.Count).ClearContents
Range("A43").Resize(UBound(x) + 1).Value = Application.Transpose(x)
End Sub
Private Sub Check_Duplication(ByRef x As Variant, ByRef dic As Object, ByVal ky As String)
Dim y, yy, z
Dim txt As String
Dim i As Long, n As Long
y = Split(dic(ky))
txt = dic(ky)
For Each yy In y
n = dic.Count
txt = WorksheetFunction.Trim(Replace(txt, yy, ""))
If Len(txt) > 0 Then
z = Split(txt)
For i = 0 To UBound(z)
If Not InStr(1, dic(yy), z(i)) > 0 Then
z(i) = ""
End If
Next
If Len(WorksheetFunction.Trim(Join(z))) > 0 Then
dic(ky & " " & yy) = WorksheetFunction.Trim(Join(z))
Else
If UBound(Split(ky)) > 0 Then
x(UBound(x)) = "[" & Replace(ky & " " & yy, " ", ",") & "]"
ReDim Preserve x(UBound(x) + 1)
End If
End If
Else
If UBound(Split(ky)) > 0 Then
x(UBound(x)) = "[" & Replace(ky & " " & yy, " ", ",") & "]"
ReDim Preserve x(UBound(x) + 1)
End If
End If
If dic.Count > n Then Check_Duplication x, dic, ky & " " & yy
Next
End Sub
早速の対応ありがとうございます。
昨晩は酔っていたこともあり、少しくどくなってしまいました。
酔ってしまわないうちに、VerUpで、どこがどのように変わったのか、確認してみます。
弥太郎さん、ROUGEさん、表-2が広がった場合の対応は、Range("A29:M41").Valueを変える
だけでは無理ですよね。←スンマセン、まだ赤ちゃん並のおつむですから。
(困困）
> 表-2が広がった場合の対応は、Range("A29:M41").Valueを変えるだけでは無理ですよね。
基本的にそれで大丈夫ですが、結果の貼り付け位置を固定してしまっているので、その部分の修正は必要です。
(ROUGE)
それがしのんは 9行目の13を UBound(tbl, 2) 12を UBound(tbl, 2) - 1 でＯＫです。 （弥太郎）
ありがとうございます。
ROUGEさん
「結果の貼り付け位置を固定してしまっているので、その部分の修正は必要です。」 修正箇所は下記の箇所でよろしいでしょうか？また、どのように修正すれば良いか ご教授願います。
Range("A43").Resize(UBound(x) + 1).Value = Application.Transpose(x)
（困困）
> Range("A43:A" & Rows.Count).ClearContents
> Range("A43").Resize(UBound(x) + 1).Value = Application.Transpose(x)
の2箇所を修正します。
具体的には、A43を表-2と被らない場所にするだけでOKですｂ
結果を表示するシートを別に用意しても良いかもしれませんね。
(ROUGE)
ROUGEさん
ご教示ありがとうございます。
お蔭様で、仕事が捗るようになりました。 ROUGEさん、弥太郎さん本当にございました。 （困困）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.