21名で二人づつのペアでの畑の水入れ当番を作りたいと思います。２１名が

Question

21名で二人づつのペアでの畑の水入れ当番を作りたいと思います。２１名がそれぞれの所有面積に応じて当番の当たる間隔日数を出しています。期間は考えずにローテーションによって回る当番です。所有面積の多い人で最小間隔日数が（７．７４）日一名です。続いて（７．８７）一名（９．１）一名（１１．５）一名（１４．９７）一名（１９．３４）一名（２２．１）一名（２４．４３）一名（２５．７８）一名（３０．９４）三名（３８．６７）二名（４６．４）七名です。このそれぞれの間隔日数をあまり崩さないように当番を組んでいきたいのですが、二名ペアだということだとか、とても複雑でできそうにありません。
手書きで作ったりもしてみたのですが、できればエクセルで関数、を使って（マクロ）作りたいと思っています。一度詳しい方に質問したのですが、間隔日数が変動してしまい（その時は期間をきめていたので・・・）この案がメンバーに受け入れてもらえず、再びお知恵をお借りしたく質問させていただいています。私のＰＣレベルは中級ですが、マクロに関してはほとんど知識がないので、解読文章（わかりやすく）つきで、回答いただきたいと思います。
こんなの簡単だ！！と思われる方は是非回答よろしくおねがいします。

氏名　　面積　　　　　　間隔日数　　　　比較順位
Ａさん　　６０　　　　　　７．７４　　　　　　　　１
Ｂさん　　５９　　　　　　７．８７　　　　　　　　２
Ｃさん　　５１　　　　　　９．１　　　　　　　　　３
Ｄさん　　４２　　　　　　１１．０５　　　　　　　４
Ｅ　　　　　３１　　　　　　１４．９７　　　　　　５
Ｆ　　　　　２４　　　　　　１９．３４　　　　　　　６
Ｇ　　　　　２１　　　　　　２２．１　　　　　　　　７
Ｈ　　　　　１９　　　　　　２４．４３　　　　　　　８
Ｉ　　　　　　１８　　　　　　２５．７８　　　　　　　９
Ｊ　　　　　　１５　　　　　　３０．９４　　　　　　１０
Ｋ　　　　　　１５　　　　　　３０．９４　　　　　　１０
Ｌ　　　　　　１５　　　　　　３０．９４　　　　　　１０
Ｍ　　　　　　１２　　　　　　３８．６７　　　　　　１１
Ｎ　　　　　　１２　　　　　　３８．６７　　　　　　１１
Ｏ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｐ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｑ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｒ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｓ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｐ　　　　　　１０　　　　　　４６．４　　　　　　　１２
Ｕ　　　　　　１０　　　　　　４６．４　　　　　　　１２
面積　　合計４６４

このような感じです。困っています。間隔日数をある程度保ちながらできるだけ公平に組み合わせたいのです。
よろしくおねがいします。

nag0720 · Accepted Answer

＞エクセルのシートに氏名を表記したいのです。

下記のようにA列とB列に必要な情報を入力してから、VBAを実行してください。
E,F,G列に結果が表示されます。

A列　　B列
1　期間　　90
2　人数　　21
3
4　氏名　　回数
5　Ａ　　　23
6　Ｂ　　　23
7　Ｃ　　　19
8　Ｄ　　　16
9　Ｅ　　　12
10　Ｆ　　　9
11　Ｇ　　　8
12　Ｈ　　　7
13　Ｉ　　　7
14　Ｊ　　　6
15　Ｋ　　　6
16　Ｌ　　　6
17　Ｍ　　　5
18　Ｎ　　　5
19　Ｏ　　　4
20　Ｐ　　　4
21　Ｑ　　　4
22　Ｒ　　　4
23　Ｓ　　　4
24　Ｔ　　　4
25　Ｕ　　　4

Sub 当番割当()
Dim 期間 As Integer
Dim 人数 As Integer
Dim 氏名() As String
Dim 回数() As Integer

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
Dim n1 As Integer
Dim n2 As Integer
Dim p As Single
Dim q As Single
Dim 当番() As String
Dim 担当() As Single

期間 = Cells(1, 2)
人数 = Cells(2, 2)
ReDim 氏名(人数)
ReDim 回数(人数)
For i = 1 To 人数
  氏名(i) = Cells(4 + i, 1)
  回数(i) = Cells(4 + i, 2)
Next i

ReDim 当番(期間 * 2)
ReDim 担当(期間 * 2)

n = 0
For i = 1 To 人数
n1 = 0
n2 = 0
For j = 1 To 人数
If 回数(j) = 回数(i) Then
n1 = n1 + 1
If j <= i Then n2 = n2 + 1
End If
Next j

p = 期間 / 回数(i)
For j = 1 To 回数(i)
q = p * (n2 - 0.5) / n1 + p * (j - 1)
m = 1
For k = n To 1 Step -1
If 担当(k) <= q Then
m = k + 1
Exit For
End If
当番(k + 1) = 当番(k)
担当(k + 1) = 担当(k)
Next k
当番(m) = 氏名(i)
担当(m) = q
n = n + 1
Next j
Next i

Range("E:G").Clear
For n = 1 To 期間
Cells(n, 5) = n & "日"
Cells(n, 6) = 当番(n * 2 - 1)
Cells(n, 7) = 当番(n * 2)
Next n
End Sub

VBAをここで詳しく解説することはできないので、ご自分で調べてみてください。
簡単なコマンドだけですので、そんなに難しくないと思います。

難しいのは、なぜこの方法で当番の割り当てができるのかだと思いますので、簡単に説明しておきます。

期間は９０日ですが、この時間軸上に各担当者ごとに当番日時を均等に振り分けます。
例えば、Ａさんは２３回なので、90/23=3.91=3日22時間を計算して、
Ａさんの１回目：3日22時
Ａさんの２回目：7日20時
Ａさんの３回目：11日18時
Ｃさんは１９回なので、90/19=4.73=4日17時間を計算して、
Ｃさんの１回目：4日17時
Ｃさんの２回目：9日10時
Ｃさんの３回目：14日3時
というように配分します。
（実際はもう少し細かい計算をしていますが簡単に言うとこういうことです）
２１名全員について同じように配分します。
しかしこのままでは、当番がいない日があったり、３人以上が当番になる日が発生しますので、
あとは、早い順に２名づつ当番に割り当てているだけです。

この方法で割り当てると、当番の間隔日数はそんなにずれることはないと思います。

nag0720 · Answer

VBAで作成してみましたので試してみてください。
計算結果をシートに転送していますので、シートモジュールで実行してください。

Sub 当番割当()
Dim 期間 As Integer
Dim 人数 As Integer
Dim 氏名() As String
Dim 回数() As Integer

期間 = 90
人数 = 21
ReDim 氏名(人数)
ReDim 回数(人数)
氏名(1) = "Ａ": 回数(1) = 23
氏名(2) = "Ｂ": 回数(2) = 23
氏名(3) = "Ｃ": 回数(3) = 19  ' 回数の合計が181になっていたので20を19に変更しました
氏名(4) = "Ｄ": 回数(4) = 16
氏名(5) = "Ｅ": 回数(5) = 12
氏名(6) = "Ｆ": 回数(6) = 9
氏名(7) = "Ｇ": 回数(7) = 8
氏名(8) = "Ｈ": 回数(8) = 7
氏名(9) = "Ｉ": 回数(9) = 7
氏名(10) = "Ｊ": 回数(10) = 6
氏名(11) = "Ｋ": 回数(11) = 6
氏名(12) = "Ｌ": 回数(12) = 6
氏名(13) = "Ｍ": 回数(13) = 5
氏名(14) = "Ｎ": 回数(14) = 5
氏名(15) = "Ｏ": 回数(15) = 4
氏名(16) = "Ｐ": 回数(16) = 4
氏名(17) = "Ｑ": 回数(17) = 4
氏名(18) = "Ｒ": 回数(18) = 4
氏名(19) = "Ｓ": 回数(19) = 4
氏名(20) = "Ｔ": 回数(20) = 4
氏名(21) = "Ｕ": 回数(21) = 4

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
Dim n1 As Integer
Dim n2 As Integer
Dim p As Single
Dim q As Single
Dim 当番() As String
Dim 担当() As Single

ReDim 当番(期間 * 2)
ReDim 担当(期間 * 2)

n = 0
For i = 1 To 人数
  n1 = 0
  n2 = 0
  For j = 1 To 人数
    If 回数(j) = 回数(i) Then
      n1 = n1 + 1
      If j <= i Then n2 = n2 + 1
    End If
  Next j
  
  p = 期間 / 回数(i)
  For j = 1 To 回数(i)
    q = p * (n2 - 0.5) / n1 + p * (j - 1)
    m = 1
    For k = n To 1 Step -1
      If 担当(k) <= q Then
        m = k + 1
        Exit For
      End If
      当番(k + 1) = 当番(k)
      担当(k + 1) = 担当(k)
    Next k
    当番(m) = 氏名(i)
    担当(m) = q
    n = n + 1
  Next j
Next i

For n = 1 To 期間
  Cells(n, 1) = n & "日"
  Cells(n, 2) = 当番(n * 2 - 1)
  Cells(n, 3) = 当番(n * 2)
Next n
End Sub

cafe_au_lait · Answer

最小間隔日数の代わりに担当割合を使用する案です。
詳しくは添付図をご覧ください。

W2=SUM(B2:V2)
B3=B2/$W$2
B6=B$3
B7=B$3-COUNTIF($W$6:$W6,B$1)/$A6
W6=INDEX($B$1:$V$1,MATCH(MAX($B6:$V6),$B6:$V6,FALSE))

3行目でそれぞれの面積/全面積を計算、担当割合とします。
6行目以降の考え方としては、
・3行目の担当割合から、これまでの実際の担当割合（担当回数/全回数）を引く（B列～V列）
・上記の値が最も大きい（予定の担当割合への到達率が最も低い）人を担当とする（W列）
これを繰り返します。

464回分を計算した結果では、担当割合、間隔日数ともにそこそこ良い結果がえられました。

図が読みにくい等あれば補足ください。

nag0720 · Answer

疑問が１つ。

４６４日間を１周期とすると、その期間内に、Ａさんは６０回、Ｂさんは５９回、・・・、Ｕさんは１０回水入れ当番になるということですね。
そうすると、延べ回数は４６４回になります。
４６４日間で４６４回ですから、ペアで当番になるとすると、毎日ではなくて１日置きに水入れをすることになりますがそれでいいんでしょうか。

21名で二人づつのペアでの畑の水入れ当番を作りたいと思います。２１名が

＞エクセルのシートに氏名を表記したいのです。

VBAで作成してみましたので試してみてください。

この回答への補足

最小間隔日数の代わりに担当割合を使用する案です。

この回答への補足

疑問が１つ。

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング