[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『先着３０名のカウントと当選日を出したい』（たー）
受付番号 名前 住所 希望人数 第1希望 第2希望 第3希望 当選日
1 あおもり 5 6/1?@ 6/3?@ 6/5?A 6/1?@ 2 いわて 2 6/1?A 6/3?A 6/5?@ 3 ふくしま 6 6/1?@ 6/3?@ 6/5?A 番号は、180までです。 ※名前と住所の間に、年齢が来るかもしれないです。 たたき台として、このような表があります。 日程は、３日間。午前と午後があるので?@と?Aで分けます。 やりたいこととしては、先着３０名で合計１８０名募集をかけます。 その時、6/1?@の希望人数があと何人なのかがすぐ把握したいです。 また、6/1?@が３０名埋まった場合当選日を表示出来るようにしたいです。 受け付け番号が、上の達は第1希望で決まりますが下にいくにつれて 第2希望、第３希望となってきます。
どうにか自動でやりたいと思っています。
足りない作業列は、追加可能です。
これが、叶う関数を教えてください。
実際、募集が始まるのは２０日からです。
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
' 希望日程のリスト
schedule = Array("6/1?@", "6/1?A", "6/3?@", "6/3?A", "6/5?@", "6/5?A")
' ワークシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切なものに変更
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 残席数の計算
remainingSeats = 30
' 各日程に対して参加者を割り当てる
For j = LBound(schedule) To UBound(schedule)
For i = 2 To lastRow
If ws.Cells(i, "F").Value = schedule(j) Or ws.Cells(i, "G").Value = schedule(j) Or ws.Cells(i, "H").Value = schedule(j) Then
' 参加者が希望日程に参加希望の場合
If remainingSeats > 0 Then
' 残席がある場合は参加者を割り当て、残席数を減らす
ws.Cells(i, "I").Value = schedule(j)
remainingSeats = remainingSeats - 1
Else
' 残席がない場合は次の日程に進む
Exit For
End If
End If
Next i
Next j
' 最終的にどの日程に割り当てたかを表示
For j = LBound(schedule) To UBound(schedule)
If WorksheetFunction.CountIf(ws.Columns("I"), schedule(j)) < 30 Then
ws.Range("L2").Value = schedule(j)
Exit For
End If
Next j
' 残席数を表示
For j = LBound(schedule) To UBound(schedule)
remainingSeats = 30 - WorksheetFunction.CountIf(ws.Columns("I"), schedule(j))
ws.Cells(2, 10 + j).Value = remainingSeats
Next j
End Sub
番号,名前,年齢,住所,参加人数,第1希望,第2希望,第3希望,当選日 1,田中,30,東京,1,6/1?@,6/3?@,6/5?@, 2,山田,25,大阪,1,6/3?@,6/1?@,6/5?@, 3,佐藤,35,名古屋,1,6/1?@,6/5?@,6/3?@, 4,鈴木,40,福岡,1,6/5?@,6/3?@,6/1?@, 5,高橋,28,札幌,1,6/1?@,6/3?@,6/5?@,
（通勤中の通りすがり） 2024/05/14(火) 23:43:39
次に、各参加者の希望日程の中で優先度が最大である日程を選択する式です：
=IF(B2=MAX($B$2:$B$31), INDEX($F$1:$H$1, MATCH(MAX($B$2:$B$31), $B$2:$B$31, 0)), "")
に、参照するセルの範囲や位置を指します。
最初の式（優先度を割り当てる式）を使用する場合：
各参加者ごとに、希望日程が記録されているセル範囲を指定します。例えば、第1希望がF列、第2希望がG列、第3希望がH列などです。この場合、各参加者の希望日程が記録されているセル範囲は、F2:H31 のようになります。
この式は、各参加者ごとに計算されるため、各参加者のデータが格納されている行に適用される必要があります。
2番目の式（最初に参加可能な日程を選択する式）を使用する場合：
各参加者の優先度が記録されているセル範囲を指定します。例えば、優先度が記録されているセル範囲は、B2:B31 のようになります。
各参加者の希望日程が記録されているセル範囲（第1希望、第2希望、第3希望が記録されている列）も指定します。例えば、第1希望がF列、第2希望がG列、第3希望がH列などです。この場合、各参加者の希望日程が記録されているセル範囲は、F1:H1 のようになります。
この式は、各参加者の優先度を計算するために使用されます。そのため、優先度が計算される範囲は、各参加者のデータが格納されている行に合わせる必要があります。
（通りすがり） 2024/05/14(火) 23:56:10
これらの式を適切なセルにコピー＆ペーストして使用すると、各参加者の当選日を計算することができます。
（通りすがり） 2024/05/14(火) 23:58:57
（通りすがり） 2024/05/15(水) 00:53:06
=IF(B2=MAX($B$2:$B$31), INDEX($F$1:$H$1, MATCH(MAX($B$2:$B$31), $B$2:$B$31, 0)), "")
を、当選日欄にコピペ
（通りすがり） 2024/05/15(水) 01:07:43
（通りすがり） 2024/05/15(水) 01:30:53
（通りすがり） 2024/05/15(水) 08:20:08
Dim ws As Worksheet
Dim i As Long
Dim schedule As Variant
Dim fileName As String
Dim remainingSeats As Integer
' 希望日程のリスト
schedule = Array("6/1?@", "6/1?A", "6/3?@", "6/3?A", "6/5?@", "6/5?A")
' ワークシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切なものに変更
' データをクリア
ws.Cells.Clear
' ヘッダー行の設定
ws.Cells(1, 1).Value = "番号"
ws.Cells(1, 2).Value = "名前"
ws.Cells(1, 3).Value = "年齢"
ws.Cells(1, 4).Value = "住所"
ws.Cells(1, 5).Value = "電話番号"
ws.Cells(1, 6).Value = "第１希望"
ws.Cells(1, 7).Value = "第２希望"
ws.Cells(1, 8).Value = "第３希望"
ws.Cells(1, 9).Value = "当選日"
ws.Cells(1, 10).Value = "人数"
' 残席数の初期化
remainingSeats = 8
' 各行にデータを入力
For i = 1 To 50
' 番号
ws.Cells(i + 1, 1).Value = i
' 名前
ws.Cells(i + 1, 2).Value = "参加者" & i
' 年齢（20歳から50歳の間でランダム）
ws.Cells(i + 1, 3).Value = Int((50 - 20 + 1) * Rnd + 20)
' 住所
ws.Cells(i + 1, 4).Value = "住所" & i
' 電話番号（仮の番号を生成）
ws.Cells(i + 1, 5).Value = "080" & Int((9999 - 1000 + 1) * Rnd + 1000) & Int((9999 - 1000 + 1) * Rnd + 1000)
' 第１希望
ws.Cells(i + 1, 6).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第２希望
ws.Cells(i + 1, 7).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第３希望
ws.Cells(i + 1, 8).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 当選日は空欄で初期化
ws.Cells(i + 1, 9).Value = ""
' 人数（1から残席数までのランダムな整数）
ws.Cells(i + 1, 10).Value = Int(remainingSeats * Rnd) + 1
' 残席数を更新
remainingSeats = remainingSeats - ws.Cells(i + 1, 10).Value
If remainingSeats <= 0 Then
remainingSeats = 8
End If
Next i
' ファイル名の設定
fileName = ThisWorkbook.Path & "\sample_data.csv"
' CSVファイルとして保存
ws.SaveAs fileName, xlCSV
' メッセージを表示
MsgBox "サンプルデータが生成されました：" & fileName, vbInformation
End Sub
（通りすがり） 2024/05/15(水) 09:32:38
Dim ws As Worksheet
Dim i As Long
Dim schedule As Variant
Dim fileName As String
Dim remainingSeats As Integer
' 希望日程のリスト
schedule = Array("6/1?@", "6/1?A", "6/3?@", "6/3?A", "6/5?@", "6/5?A")
' ワークシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切なものに変更
' データをクリア
ws.Cells.Clear
' ヘッダー行の設定
ws.Cells(1, 1).Value = "番号"
ws.Cells(1, 2).Value = "名前"
ws.Cells(1, 3).Value = "年齢"
ws.Cells(1, 4).Value = "住所"
ws.Cells(1, 5).Value = "電話番号"
ws.Cells(1, 6).Value = "第１希望"
ws.Cells(1, 7).Value = "第２希望"
ws.Cells(1, 8).Value = "第３希望"
ws.Cells(1, 9).Value = "当選日"
ws.Cells(1, 10).Value = "人数"
' 残席数の初期化
remainingSeats = 8
' 各行にデータを入力
For i = 1 To 50
' 番号
ws.Cells(i + 1, 1).Value = i
' 名前
ws.Cells(i + 1, 2).Value = "参加者" & i
' 年齢（20歳から50歳の間でランダム）
ws.Cells(i + 1, 3).Value = Int((50 - 20 + 1) * Rnd + 20)
' 住所
ws.Cells(i + 1, 4).Value = "住所" & i
' 電話番号（仮の番号を生成）
ws.Cells(i + 1, 5).Value = "080" & Int((9999 - 1000 + 1) * Rnd + 1000) & Int((9999 - 1000 + 1) * Rnd + 1000)
' 第１希望
ws.Cells(i + 1, 6).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第２希望
ws.Cells(i + 1, 7).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第３希望
ws.Cells(i + 1, 8).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 当選日は空欄で初期化
ws.Cells(i + 1, 9).Value = ""
' 人数（1から残席数までのランダムな整数）
ws.Cells(i + 1, 10).Value = Int(remainingSeats * Rnd) + 1
' 残席数を更新
remainingSeats = remainingSeats - ws.Cells(i + 1, 10).Value
If remainingSeats <= 0 Then
remainingSeats = 8
End If
Next i
' ファイル名の設定
fileName = ThisWorkbook.Path & "\sample_data.csv"
' CSVファイルとして保存
ws.SaveAs fileName, xlCSV
' メッセージを表示
MsgBox "サンプルデータが生成されました：" & fileName, vbInformation
End Sub
（通りすがり） 2024/05/15(水) 09:33:14
Dim ws As Worksheet
Dim lastRow As Long, newRow As Long, i As Long
Dim schedule As Variant
Dim remainingSeats As Integer
' 希望日程のリスト
schedule = Array("6/1?@", "6/1?A", "6/3?@", "6/3?A", "6/5?@", "6/5?A")
' ワークシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切なものに変更
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 残席数の計算
remainingSeats = 30
' 新しいデータを追加する行を決定
newRow = lastRow + 1
' 各行にデータを入力
For i = newRow To newRow + 179
' 番号
ws.Cells(i, 1).Value = i - 1
' 名前（適宜変更）
ws.Cells(i, 2).Value = "参加者" & (i - 1)
' 年齢（適宜変更）
ws.Cells(i, 3).Value = Int((50 - 20 + 1) * Rnd + 20)
' 住所（適宜変更）
ws.Cells(i, 4).Value = "住所" & (i - 1)
' 電話番号（適宜変更）
ws.Cells(i, 5).Value = "電話番号" & (i - 1)
' 第１希望
ws.Cells(i, 6).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第２希望
ws.Cells(i, 7).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 第３希望
ws.Cells(i, 8).Value = schedule(Int((UBound(schedule) + 1) * Rnd))
' 当選日は空欄で初期化
ws.Cells(i, 9).Value = ""
Next i
' 残席数を更新
ws.Cells(182, 9).Value = remainingSeats
End Sub
（通りすがり） 2024/05/15(水) 09:38:50
Excel365なので、関数でできるのかもしれませんが、私には環境がありませんので、 マクロ案を提示しておきます。 ・以下のレイアウトにしたうえで、 ・下記のマクロ を標準モジュールにコピーして ・マクロmainを実行してみて下さい。
【シートレイアウト】 ・A列からH列にはリクエストを入力してください。 ・Q1:V2に 実施日時 を入力してください。（日時はそちらで自由に設定して下さい） ・他のセルは、マクロで作成します。
【マクロ実行前】 A B C D E F G H I J K L M N O P Q R S T U V W 受付順No 名前 住所 希望人数 第1希望 第2希望 第3希望 実施日1 実施日2 実施日3 実施日4 実施日5 実施日6 1 5 6/1A 6/3A 6/5B 6/1A 6/1B 6/3A 6/3B 6/5A 6/5B
【マクロ実行後】 ・I列～N列までが、受付番号ごと の決定内容です。 ・Q7～ V36までが、実施日時ごと の決定内容です。 A B C D E F G H I J K L M N O P Q R S T U V W 受付順No 名前 住所 希望人数 第1希望 第2希望 第3希望 結果 実施日1 実施日2 実施日3 実施日4 実施日5 実施日6 1 5 6/1A 6/3A 6/5B 6/1A 5 6/1A 6/1B 6/3A 6/3B 6/5A 6/5B 2 2 6/1B 6/3B 6/5A 6/1B 2 限度 30 30 30 30 30 30 3 3 6/1A 6/3A 6/5B 6/1A 3 割当済み 30 30 30 30 30 30 4 2 6/5B 6/1B 6/5A 6/5B 2 余裕 0 0 0 0 0 0 0 5 4 6/1A 6/3A 6/5B 6/1A 4 6 1 6/5A 6/1A 6/3B 6/5A 1 当選者 当選者 当選者 当選者 当選者 当選者 7 4 6/1A 6/3A 6/5B 6/1A 4 1 2 11 34 6 4 8 2 6/1B 6/5B 6/3A 6/1B 2 1 2 12 34 9 4 9 4 6/5A 6/1A 6/3B 6/5A 4 1 8 12 34 9 19 10 2 6/5A 6/3B 6/5B 6/5A 2 1 8 16 34 9 19 11 1 6/3A 6/1B 6/5B 6/3A 1 1 13 16 34 9 19 12 2 6/3A 6/1A 6/3B 6/3A 2 3 13 16 36 10 19 13 以下、記載省略
【マクロ】(マジックナンバーだらけで失礼）
Sub main()
Dim k&, j&
Dim nr&, num&
Dim req$
Dim d&
Dim allowance&, numOK&
Dim pos&
'初期設定
Range("I:N").ClearContents
[P3] = "限度": [P4] = "割当済み": [P5] = "余裕"
[Q3:V3] = 30
[Q4:V4] = 0
[Q5:V5].Formula = "=Q3-Q4"
[W5].Formula = "=SUM(Q5:V5)"
[Q7:V7] = "当選者"
[Q8].Resize(30, 6).ClearContents
'各受付番号の若い順（≒優先度高い順）に、決定していく
For k = 2 To Cells(Rows.Count, "A").End(xlUp).Row
nr = Cells(k, "A")
num = Cells(k, "E")
For j = 1 To 3
req = Cells(k, 5 + j) '希望日時
d = Application.Match(req, [Q2:V2]) + 16 '対応する列
allowance = Cells(5, d) 'その日時の余裕人数
If num <= allowance Then
numOK = num
Cells(4, d) = Cells(4, d) + numOK '割当済み数の更新
Cells(k, 9) = Cells(2, d) '希望日
''希望順位別に分ける場合は、下記を使って下さい。
''Cells(k, 10 + (j - 1) * 2) = numOK '割当済み人数
'当選者一覧への書き込み
pos = Cells(Rows.Count, d).End(xlUp).Row + 1
Cells(pos, d).Resize(numOK, 1) = nr
End If
If num = 0 Then Exit For
Next
If Cells(5, "W") = 0 Then Exit For
Next
End Sub
一応、結果が出ることは確認しています。
なお、希望人数が例えば5人のとき、第一希望に3人、第二希望に2人という割り当てはせず、 同じ日時に5人の空きがなければ、割り当てない、としています。 （分割しても可という考えかたもあるかもしれません）
（xyz） 2024/05/16(木) 19:35:41
200行までに修正。受付番号A列、人数D列、希望E:G列の場合。
=LET(x,E2:G200,
E,LAMBDA(i,TOCOL(IF(SEQUENCE(,COLUMNS(x)),i),,TRUE)),
y,HSTACK(E(A2:A200),E(D2:D200),E(x)),
z,SORT(UNIQUE(TOROW(x,1),TRUE),,,TRUE),
w,REDUCE("",z,LAMBDA(s,t,LET(
b,FILTER(y,(TAKE(y,,-1)=t)*BYROW(TAKE(y,,1),LAMBDA(i,COUNT(0/(FIND(i&"(",s)=1))=0))),
c,ISNUMBER(SCAN(0,INDEX(b,,2),LAMBDA(s,t,IF(s+t>30,s&"",s+t)))),
HSTACK(s,IFERROR(FILTER(INDEX(b,,1)&"("&INDEX(b,,2)&"名)",c,""),""))))),
VSTACK(z,IFERROR(DROP(w,,1),"")))
（んなっと） 2024/05/17(金) 11:15:22
H列に縦方向に結果を表示させたいときは
H2
=LET(p,A2:A200,q,D2:D200,r,E2:G200,n,XMATCH(TRUE,p<>"",,-1),x,TAKE(p,n),
E,LAMBDA(i,TOCOL(IF(SEQUENCE(,COLUMNS(r)),i),,TRUE)),
y,HSTACK(E(x),E(TAKE(q,n)),E(TAKE(r,n))),
z,SORT(UNIQUE(TOROW(r,1),TRUE),,,TRUE),
w,REDUCE("",z,LAMBDA(s,t,LET(
b,FILTER(y,(TAKE(y,,-1)=t)*BYROW(TAKE(y,,1),LAMBDA(i,COUNT(0/(i&""=s&""))=0))),
c,ISNUMBER(SCAN(0,INDEX(b,,2),LAMBDA(s,t,IF(s+t>30,s&"",s+t)))),
HSTACK(s,IFERROR(FILTER(INDEX(b,,1),c,""),""))))),
u,IFERROR(DROP(w,,1),""),
XLOOKUP(TAKE(x,,1),TOCOL(u),TOCOL(IF(u="","",z))))
（んなっと） 2024/05/18(土) 06:14:35
回答があるのに何故沈黙されているのでしょうか。もう用済みなんですか? それでは原始的な式計算による方法を示します。
■レイアウト （求める結果はM列）
A B C D E F G H I J K L M N O P Q R S T 1 実施日1 実施日2 実施日3 実施日4 実施日5 実施日6 2 6/1A 6/1B 6/3A 6/3B 6/5A 6/5B 3 No 名前 ? 住所 希望人数 第1希望 第2希望 第3希望 決定 30 30 30 30 30 30 4 1 5 6/1A 6/3A 6/5B 1 3 6 6/1A 25 30 30 30 30 30 5 2 2 6/1B 6/3B 6/5A 2 4 5 6/1B 25 28 30 30 30 30 6 3 3 6/1A 6/3A 6/5B 1 3 6 6/1A 22 28 30 30 30 30
・A列～I列までは入力済みデータ ・J列以降は、作業列 ・M列が決定した日時です。
【計算式】
・J4 =MATCH(F4,$O$2:$T$2,0)
・K4 =MATCH(G4,$O$2:$T$2,0)
・L4 =MATCH(H4,$O$2:$T$2,0)
・M4 =IF(E4<=INDEX(O3:T3,1,J4),
F4,
IF(E4<=INDEX(O3:T3,1,K4),
G4,
IF(E4<=INDEX(O3:T3,1,L4),
H4,"")))
・O4 =IF($M4=O$2,O3-$E4,O3)
・O4 を P4～T4にコピーペイスト
・以上の J4～T4を下にコピーペイストします。
--------------------------- なお、以下の条件付き書式を設定すると結果が見やすいかもしれません。
●何番目の希望が通ったかを示す条件付き書式 対象範囲: F4:H183 式 =F4=$M4 塗りつぶし色を適宜指定
●決定によって余裕人数が減少したセルを示す条件付き書式 対象範囲: O4:T183 式 =O4<>O3 塗りつぶし色を適宜指定
（xyz） 2024/05/21(火) 10:34:38
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.