質問: 重複しないグループ分けについて https://oshiete.goo.ne.jp/qa/8843774.html で質問してプログラムを組んでくれた方がいましたが 応用できない場面が出てきてしまったので再び質問させて いただきます。 前回の質問ではすべて3グループに分けられるように していただきましたが、実はグループ数を固定するのではなく 1グループの人数を3人に固定しなければならなかったのです。 前回回答していただいたvbaのプログラムを編集して 1~12までを3ずつ4グループになるべく重複をしないで 複数回、分けるにはどうしたらいいでしょうか? できれば複数回分けたところで全部の数が最低1回は同じ グループに入るようにできると助かります。 今回も1-2-12と1-2-11は重複と考えます。 まったく重複なしで行うのは不可能だということは わかりますが、できるだけ少ない重複で複数回(今回は最低6回)のグループ分け を行いたいと思います。 前回のプログラムに説明も付け加えていただきましたが よく理解できずに今日まできてしまいました。 大変申し訳ありませんがどうかご教授お願いします。
回答: 【つづき】 上記で出来上がった表を元に、組合せパターン数の表を作成するもの #7後半にもありましたが、その表の右側に 1_2_3 の様な表示を追加しています。 #7後半のものでも構いません。 public sub checkptn() dim dicptn as object dim va as variant, vb as variant, v as variant dim i as long, j as long, k1 as long, k2 as long dim igrp as long dim vs as variant, ss as string set dicptn = createobject("scripting.dictionary") with range("b2") va = .currentregion.value igrp = .cells(1).mergearea.count redim vb(1 to ubound(va, 2) + 1, 1 to ubound(va, 2) + 1) vb(1, 1) = "組" for i = 2 to ubound(vb) vb(1, i) = i - 1 vb(i, 1) = i - 1 vb(i, i) = "a" next for i = 2 to ubound(va) if (val(va(i, 1)) > 0) then for j = 1 to ubound(va, 2) step igrp ss = "" for k1 = 0 to igrp - 2 ss = ss & "_" & va(i, j + k1) for k2 = k1 + 1 to igrp - 1 vb(va(i, j + k1) + 1, va(i, j + k2) + 1) = _ vb(va(i, j + k1) + 1, va(i, j + k2) + 1) + 1 vb(va(i, j + k2) + 1, va(i, j + k1) + 1) = _ vb(va(i, j + k2) + 1, va(i, j + k1) + 1) + 1 next next ss = ss & "_" & va(i, j + k1) ss = mid(ss, 2) dicptn(ss) = dicptn(ss) + 1 next end if next with .offset(ubound(va) + 2) .currentregion.clear with .resize(ubound(vb), ubound(vb)) .value = vb on error resume next .cells.specialcells(xlcelltypeblanks) _ .interior.colorindex = 38 .offset(1, 1).resize(.rows.count - 1, .columns.count - 1) _ .specialcells(xlcelltypeconstants _ , xltextvalues).clearcontents .columns(1).interior.colorindex = 36 .rows(1).interior.colorindex = 36 .borders.linestyle = xlcontinuous .horizontalalignment = xlcenter .entirecolumn.autofit end with redim vs(1 to dicptn.count, 1 to 2) i = 1 for each v in mysort2(dicptn.keys) vs(i, 1) = join(v(1), "_") vs(i, 2) = dicptn(v(0)) i = i + 1 next with .offset(, ubound(vb) + 1) .currentregion.clear with .resize(dicptn.count, 2) .value = vs .borders.linestyle = xlcontinuous end with end with end with end with set dicptn = nothing end sub private function mysort2(byval va as variant) as variant dim vr as variant, vs as variant, v as variant dim i as variant, j as variant, k as long, n as long redim vr(lbound(va) to ubound(va)) for i = lbound(va) to ubound(va) vs = split(va(i), "_") for j = 0 to ubound(vs) - 1 for k = j + 1 to ubound(vs) if (int(vs(j)) > int(vs(k))) then v = vs(j) vs(j) = vs(k) vs(k) = v end if next next vr(i) = array(va(i), vs) next for i = lbound(vr) to ubound(vr) - 1 for j = i + 1 to ubound(vr) for k = 0 to ubound(vs) if (int(vr(i)(1)(k)) < int(vr(j)(1)(k))) then n = 0 exit for elseif (int(vr(i)(1)(k)) > int(vr(j)(1)(k))) then n = 1 exit for end if next if (n > 0) then v = vr(i) vr(i) = vr(j) vr(j) = v end if next next mysort2 = vr end function ※ mysort2 は、文字列で与えられたものを1度バラして・・・ってやってます (元々数値の表側を見ればもっと少ない記述になりますが)