エクセルを使用し以下のようにグループ分けする仕組みを作りたいです。 VBAでも関数でも構いません。

Excel44閲覧

ベストアンサー

0
画像

ThanksImg質問者からのお礼コメント

ありがとうございます!

お礼日時:6/16 15:21

その他の回答(2件)

0

A2セルから下方に10人な名前が、B2セルから下方に重みが入力された表とします。 作業列を作って対応します。 G2セルには次の式を入力して下方にドラッグコピーします。 IF(B2="","",B2*100+COUNTIF(B$1:B1,B2)) その後に2つのグループのメンバーの名前をD列とE列に表示するとしたらD2セルには次の式を入力してE2セルまで横にドラッグコピーしたのちに下方にもドラッグコピーすればよいでしょう。 =IF(ROW(A1)>5,"",IF(COLUMN(A1)=1,INDEX($A:$A,MATCH(LARGE($G:$G,ROW(A1)),$G:$G,0)),IF(COLUMN(A1)=2,INDEX($A:$A,MATCH(SMALL($G:$G,ROW(A1)),$G:$G,0)),""))) なお、作業列が目障りでしたらその列を選択して「非表示」にすればよいでしょう。

0

1.10人中5人の組み合わせを全部拾い出す 2.1の中から合計ポイントが21になる組み合わせのみ残す 3.実際の組み合わせは2の半分 作業用のシート「work」を用意して下さい。 Sheet1に添付図のように、A列に人名、B列に重みを、1行目から記入しておいて下さい。 Sheet1からSub Mainを走らせて下さい。 全部で12通りの組み合わせがありました。 添付図の罫線と塗りつぶしは後から手動で入れてます。 Option Explicit     Const Moto = 10 '--------全員の人数     Const Nuki = 5 '--------1チームの人数     Const MidPoint = 21 '---均衡ポイント     Dim WS As Worksheet     Dim RowNo     Dim Arry(Nuki), Hito(Moto, 2), Omomi(Moto)     Dim LastRW Private Sub Kumiawase(Depth, MaeNo) '---10人中5人をの全組み合わせをworkシートに出力(再帰呼出し)     Dim N, C     For N = MaeNo + 1 To Moto - Nuki + Depth         Arry(Depth) = N         If Depth = Nuki Then             For C = 1 To Nuki                 WS.Cells(RowNo, C) = Arry(C)             Next C             RowNo = RowNo + 1         Else             Call Kumiawase(Depth + 1, N)         End If     Next N End Sub Sub Main()     Dim R, N, C1, C2     Set WS = Worksheets("work")     WS.UsedRange.ClearContents     '---10人中5人をの全組み合わせをworkシートに出力(再帰)     RowNo = 1     Call Kumiawase(1, 0)     '---人名と重みを配列に代入     For R = 1 To Moto         Hito(R, 1) = Cells(R, 1)         Omomi(R) = Cells(R, 2)     Next R     '---均衡ポイントにならない組み合わせを消す     LastRW = WS.Cells(Rows.Count, 1).End(xlUp).Row     For R = LastRW To 1 Step -1         If CalcPoint(R) <> MidPoint Then             WS.Rows(R).Delete         End If     Next R     LastRW = WS.Cells(Rows.Count, 1).End(xlUp).Row     '---実際の組み合わせは半分     For R = 1 To LastRW / 2         '---選ばれた組み合わせの人を1に、残りの人を0に         For N = 1 To Moto             Hito(N, 2) = 0         Next N         For N = 1 To Nuki             Hito(WS.Cells(R, N), 2) = 1         Next N         C1 = 4 '---1チーム目一人目の出力列         C2 = 10 '---2チーム目一人目の出力列         For N = 1 To Moto             Select Case Hito(N, 2)                 Case 1                     Cells(R, C1) = Hito(N, 1)                     C1 = C1 + 1                 Case 0                     Cells(R, C2) = Hito(N, 1)                     C2 = C2 + 1             End Select         Next N     Next R End Sub Private Function CalcPoint(R) '---組み合わせのポイントを計算     Dim Total, C     Total = 0     For C = 1 To Nuki         Total = Total + Omomi(WS.Cells(R, C))     Next C     CalcPoint = Total End Function

画像