[[20070730142309]]　『クラブの希望調査表』（fuki）　ページの最後に飛ぶ

『クラブの希望調査表』（fuki）

第１希望～第３希望までを小学生１００人くらい調査しました。クラブにはそれぞれ最大収容人数があるので、そのデータを表にあらわした後、６年生から優先してクラブを決定したいです。どんな関数を使ったらよいのでしょうか？よろしくお願いします。

 一般の関数では・・・困難だと思います。
 ６年生の第１希望から順に各クラブに振り分け、第２・第３希望までで全員が入りきるのか？とか。
 ６年生であれば、たとえ第３希望であっても、５年生の第１希望より優先していくのか？とか。
 クラブ数・最大人数等も不明確ですし。

 相当判断基準を明確できなければ、Excelさんは何も考えてはくれないです。

 回答でなく、すみません。
 (じゅんじゅん)

 これは「みやほ大明神の未解決ログ解消」の解消を目的に2007/8/4 11:30　頃投稿しました。
 >一般の関数では・・・困難だと思います
 との事ですのでマクロで迫ってみます。

 	A	B	C	   D	      E
 1  氏名	        学年	第１希望	第２希望	 第３希望
 2  Ａ．ドロン	4	バレー	 野球	   卓球
 3  Ｊ.ギャバン	5	バレー	 野球	   卓球
 4  Ｓ．ローレン	5	野球	 ソフト	   将棋
 5  Ｍ．モンロー	6	野球	 ソフト	   バドミントン
 6  Ｇ．クーパー	6	野球	 将棋	   バドミントン
 7  Ｊ.ウエィン	6	囲碁	 ソフト	   卓球
 8  Ｋ．ダグラス	5	バドミントン ソフト  野球
 ↑のようにデータを並べます。これは数に制限はありまへん。

     H	  I	J	K	L	     M	          N      
 1  野球	ソフト	バレー	卓球	バドミントン 将棋	        囲碁
 2  20	20	18	10	12	    10	          10

 今度はＨ列からクラブ名とその募集人員を並べます。クラブ数に制限はござんせん。
 優先順位は学年順ですが、第２希望の学年上位より第１希望を、また第３希望の学年
 上位より第２希望を優先しとります。
 更に運悪くどのクラブにも入れなかったばやいは、登録順に優先順位が確定されます。
 そして選定から漏れた子ども達にはその名前欄を黄色に染めて慰めております。
   　　　　　（弥太郎）
 '---------------------------
 Sub 希望通り()
    Dim dic As Object, i As Long, n As Integer, b As Integer, tbl, x, y(), ary
    Dim data As String, dic1 As Object, ky, tbl_1, mxrow As Long, mxcol As Integer

    Set dic1 = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    tbl = Cells(2, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1, 5)
    mxcol = Cells(1, Columns.Count).End(xlToLeft).Column
    Cells(3, 8).Resize(UBound(tbl, 1), mxcol - 7).ClearContents
    Range("a:a").Interior.ColorIndex = xlNone
    For b = 1 To 3
        dic.removeall
        For i = 1 To UBound(tbl, 1)
            ReDim Preserve y(i - 1)
            y(i - 1) = tbl(i, 2)
            If Not IsEmpty(tbl(i, 1)) Then
                data = tbl(i, 2) & "," & tbl(i, b + 2)
                If Not dic.exists(data) Then
                    dic(data) = Array(tbl(i, 1))
                Else
                    x = dic(data)
                    ReDim Preserve x(UBound(x) + 1)
                    x(UBound(x)) = tbl(i, 1)
                    dic(data) = x
                End If
            End If
        Next i
        ary = Array(y)
        For n = 8 To mxcol
            For i = 6 To 1 Step -1
                For Each ky In dic.keys
                    If IsError(Application.Match(i, ary, 0)) Then Exit For
                    If dic1.exists(Split(ky, ",")(1)) Then dic.Remove ky: Exit For
                    If Not IsEmpty(ky) Then
                        If Cells(1, n) = Split(ky, ",")(1) And Split(ky, ",")(0) * 1 = i Then
                            x = dic(ky)
                            Cells(Cells(Rows.Count, n).End(xlUp).Row + 1, n).Resize(UBound(x) + 1) = _
                                        Application.Transpose(x)
                            dic.Remove ky
                            If Cells(Rows.Count, n).End(xlUp).Row - 2 >= Cells(2, n) Then
                                dic1(Cells(1, n).Value) = Empty
                            End If
                            Exit For
                        End If
                    End If
                Next ky
            Next i
        Next n
        dic.removeall
        For n = 8 To mxcol
            mxrow = Cells(Rows.Count, n).End(xlUp).Row - 2
            If mxrow >= Cells(2, n) Then
                Cells(1, n).Offset(Cells(2, n) + 2).Resize(mxrow).ClearContents
            End If
        Next n
        tbl_1 = Cells(1, 8).Resize(Range("h:j").Cells.Find("*", , , , xlByRows, xlPrevious).Row, mxcol - 7)
        For i = 3 To UBound(tbl_1, 1)
            For n = 1 To UBound(tbl_1, 2)
                If Not IsEmpty(tbl_1(i, n)) Then
                    dic(tbl_1(i, n)) = Empty
                End If
            Next n
        Next i
        For i = 1 To UBound(tbl, 1)
            If Not IsEmpty(tbl(i, 1)) Then
                data = tbl(i, 1)
                For n = 1 To UBound(tbl, 2)
                    If dic.exists(data) Then
                        tbl(i, n) = Empty
                    ElseIf dic1.exists(tbl(i, n)) Then
                        tbl(i, n) = Empty
                    End If
                Next n
            End If
        Next i
    Next b
    For i = 2 To UBound(tbl, 1) + 1
        If Not dic.exists(Cells(i, 1).Value) Then
            Cells(i, 1).Interior.ColorIndex = 6
        End If
    Next i
    Application.ScreenUpdating = True
    Set dic = Nothing
 End Sub

コメント返信：

[ 一覧(最新更新順) ]

[[20070730142309]] 『クラブの希望調査表』（fuki） ページの最後に飛ぶ

[[20070730142309]]　『クラブの希望調査表』（fuki）　ページの最後に飛ぶ