[[20200509110315]]　『過去ログ「クラブの希望調査票」の追加質問』（まーち）　ページの最後に飛ぶ

『過去ログ「クラブの希望調査票」の追加質問』（まーち）

投稿
[[20101101171055]] 『クラブ希望調査表（上位から決定）』（しーたけ）　
について...

上記投稿を参考に作らせていただいているのです。調べながらコードを変えたりしたのですが、うまくいきませんでした。すみませんが、次のように変更するためには、どのようにすればよいでしょうか。

したいことは３つあります。「第〇希望を増やしたい」、「第１希望の開始をもっと後ろにしたい」、「第〇希望の最後に、決定したクラブを出力したい」です。

例えば、下記の元データを参考にしますが、C列が組、D列が出席番号だったとして、希望は題６希望まで（E列～J列）とるとします。最後にK列に確定したクラブを出力（ない場合は空白）するとすれば、どのようにコードを変えればよいでしょうか。

どうぞよろしくお願いします。

 A	B	C	D	E
 氏名	学年	第１	第２	第３希望
 あ	4	囲碁	将棋	卓球
 い	4	将棋	囲碁	バドミントン
 う	4	囲碁	将棋	バドミントン
 え	4	将棋	囲碁	卓球
 お	4	囲碁	将棋	バドミントン
 か	4	将棋	囲碁	卓球
 き	4	囲碁	将棋	卓球

 G	H	I	J	K	L	M	N
 種目	野球	ソフト	バレー	卓球	バドミントン	将棋	囲碁
 定員	9	9	6	2	2	2	2

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

コードを載せておきます。

 Sub 希望調査結果()
   Dim clubNum As Object
   Set clubNum = CreateObject("Scripting.Dictionary")

   Dim c As Long
   Dim mxCol As Long
   mxCol = Cells(1, Columns.Count).End(xlToLeft).Column
   For c = 8 To mxCol
       clubNum.Add Cells(1, c).Value, CInt(Cells(2, c).Value)
   Next

   Dim r As Long
   Dim mxRow As Long

   mxRow = Cells(Rows.Count, 1).End(xlUp).Row
   Range("H3").Resize(Rows.Count - 2, mxCol).Clear
   Range("A2").Resize(mxRow - 1, 1).Interior.ColorIndex = 3
   Range("B2").Resize(mxRow - 1, 5).Interior.ColorIndex = 2
   Range("A1").Resize(mxRow, 5).Borders.LineStyle = xlContinuous

   For r = 2 To mxRow
        For c = 3 To 5
           If clubNum.exists(Cells(r, c).Value) Then
               If Cells(r, 1).Interior.ColorIndex = 3 Then
                   If clubNum.Item(Cells(r, c).Value) > 0 Then
                       Cells(r, 1).Interior.ColorIndex = 2
                       Cells(r, c).Interior.ColorIndex = 35
                       With Range("H1").Resize(1, mxCol - 7).Find(Cells(r, c).Value, lookat:=xlWhole)
                           Cells(Cells(Rows.Count, .Column).End(xlUp).Row + 1, .Column) = Cells(r, 1).Value
                       End With
                       clubNum.Item(Cells(r, c).Value) = clubNum.Item(Cells(r, c).Value) - 1
                   End If
               End If
           Else
               Cells(r, c).Interior.ColorIndex = 3
           End If
       Next
   Next
 End Sub

（まーち） 2020/05/09(土) 11:26

深く考えたわけではありません。
適当に、列に関する数字等を修正してみました。

 For c = 13 To mxCol

 Range("M3").Resize(Rows.Count - 2, mxCol).Clear

 Range("B2").Resize(mxRow - 1, 10).Interior.ColorIndex = 2
 Range("A1").Resize(mxRow, 10).Borders.LineStyle = xlContinuous

 For c = 5 To 10

（マナ） 2020/05/09(土) 15:27

マナさん

返信ありがとうございます。うまくできました！ありがとうございます。

もしよろしければ、したいことの３つ目はどのようにすればよいでしょうか。

第〇希望の最後に、確定したクラブを出力したいです。

よろしくお願いします。
（まーち） 2020/05/10(日) 09:22

質問をよく読んでいませんでした。
今度も、適当ですが…

             With Range("M1").Resize(1, mxCol - 7).Find(Cells(r, c).Value, lookat:=xlWhole)
                 Cells(Cells(Rows.Count, .Column).End(xlUp).Row + 1, .Column) = Cells(r, 1).Value
                 Cells(r, 11).Value=.Value   '★追加

（マナ） 2020/05/10(日) 10:28

こうだったかも

 With Range("M1").Resize(1, clubNum.count).Find(Cells(r, c).Value, lookat:=xlWhole)

（マナ） 2020/05/10(日) 10:50

マナさん

す、すごい！どちらにしてもうまく動きました。
今日は手元に必要なデータがないですが、週明けすぐに試してみます。

本当にありがとうございました！！
（まーち） 2020/05/10(日) 15:07

コメント返信：

[ 一覧(最新更新順) ]

[[20200509110315]] 『過去ログ「クラブの希望調査票」の追加質問』（まーち） ページの最後に飛ぶ

[[20200509110315]]　『過去ログ「クラブの希望調査票」の追加質問』（まーち）　ページの最後に飛ぶ