[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『社員をランダムなペアに振り分ける方法』（はなふだ）
社員を条件付きのランダムなペアに振り分ける方法をご教示くださいませ。
ただし以下の前提がございます。
【前提】
１．社員1人につき1〜2個の職種を抱えている。
２．ペア同士の職種は1つでもかぶってはならない。
３．ボタン・再計算等で簡易にペアを再作成できる
【現状シートに記載してること】
●A列：社員名
●B列：役職１
●C列：役職２
●役職リスト
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
>ペア同士の職種は1つでもかぶってはならない。 これについてのデータはないんですか。 回答できませんよ。 >【現状シートに記載してること】 にどのように振り分けるんですか。 （???） 2022/07/07(木) 14:44
参考までに、
・社員の数（データの数）と
・作りたいペアの数、
などを示してはいかがですか？
それから、ご自分ではどこまでトライしていますか？
（γ） 2022/07/07(木) 19:56
こんにちは。コメントがなく残念でした。
普通は、特定の役職について、それとは重ならない役職を決めて、 その組み合わせを抽出する方法を用いて、 数の多い役職からマッチングしていけば、 わりと現実的に手作業でできるのではないかと想像します。 （何事も機械でやってしまうと、どんな妙なことが起きるかわかりませんから、 こうしたものは、手で少しトライしてみるとよいかと思います。)
■コメントもないので、以下、自由に書かせてもらいます。
全員を、「高い役職の層」と、「そうでない層」の2グループにわけて、 二つの層からメンバーを選んで、役職が重ならない範囲でペアを作ればよいことになります。 できる限り多くのペアを作るのが目的です。
こうしてみると、これは「二部グラフの最大マッチング」を求めるという、 割と有名な問題と同じだと気づきます。 （例えば、下記の、高校数学の美しい物語「二部グラフの最大マッチングと増加道」を参照。） https://manabitimes.jp/math/1147
（実は、私は、 [[20211001205847]]で同じテーマの投稿をしていたのでした。 大分時間が経ってから気づきました。とほほ。 あちらも音沙汰なしでした。こちらも現時点で返事がないし、同様になりそうですな。）
■コードを書いて簡単なテストをしてみました。
レイアウトはこんな感じです。（説明を簡単にするため、20人としました） ・A1:C21が与えられた表。 ・E1:F11がペア候補案です。 ・H1:R11はそれをクロス表で表示したものです。
A B C D E F G H I J K L M N O P Q R
1 member役１ 役２ mem1 mem2 P11 P12 P13 P14 P15 P16 P17 P18 P19 P20
2 P01 t1 P10 P11 P01 〇
3 P02 t2 P09 P12 P02 〇
4 P03 t1 t2 P04 P13 P03 〇
5 P04 t3 P07 P14 P04 〇
6 P05 t4 P08 P15 P05 〇
7 P06 t5 t6 P05 P16 P06 〇
8 P07 t1 P02 P17 P07 〇
9 P08 t2 P06 P18 P08 〇
10 P09 t3 P01 P19 P09 〇
11 P10 t4 P03 P20 P10 〇
12 P11 t1
13 P12 t2
14 P13 t1 t2
15 P14 t3
16 P15 t4
17 P16 t5 t6
18 P17 t1
19 P18 t2
20 P19 t3
21 P20 t4
・与えられた表の上半分と下半分の２グループとするものとしました。 ・実際には、役職の高低でふたつに分けたほうが効率が良いと思います。 ・うまくいかない場合は、最初の表を乱数かなにかでシャッフルして再実行するとよいかもしれません。
・実行時間は、500人で2秒かかりませんでしたので、 仮に数千人単位に増やしても処理が返ってこないといったひどいことにはならないと思います。
分かりにくいコードかも知れませんが、興味あるかたはどうぞご笑覧下さい。
【参考コード】 Option Explicit
Dim n As Long Dim n1 As Long Dim n2 As Long
Dim ws1 As Worksheet Dim visited As Object Dim matched() As Long Dim gr() As Variant
Sub main()
Dim myCnt As Long
Dim k As Long
Dim p As Long
Set ws1 = Worksheets("Sheet1")
n = ws1.Cells(Rows.Count, "A").End(xlUp).Row - 1 '便宜上偶数人とする
n1 = n / 2
n2 = n1
gr = setData() 'グラフの構築
'■matchedが求めるもの。
'Group2の人が、Group1の誰とペアになるかを表す一次元配列。
'以下、メンバーは人名ではなく、表のなかで何番目に書かれているかのindexで扱う
ReDim matched(n1 + 1 To n1 + n2) As Long
For k = n1 + 1 To n1 + n2 '初期化
matched(k) = -1
Next
'■visitedは、調べたGr2のメンバー(index扱い）からなるdictionary
Set visited = CreateObject("Scripting.Dictionary")
'
For p = 1 To n1
visited.RemoveAll
Call dfSearch(p, visited) ''' ここが主要なアルゴリズム
Next
Debug.Print "実現したペアの個数は " & myCount()
Call setColor ' マッチングの結果をシートに反映
End Sub
Function setData() As Variant
Dim dic As Object
Dim j&, k&
Dim s$, s1$, s2$, ss$
Dim ary, e
Dim matchflag As Boolean
Dim a
Set dic = CreateObject("Scripting.Dictionary")
' dic Key:CStr(j), item:カンマで連結した役職
For j = 1 To n
s = ws1.Cells(j + 1, 1)
s1 = ws1.Cells(j + 1, 2)
s2 = ws1.Cells(j + 1, 3)
If s2 <> "" Then
dic(CStr(j)) = s1 & "," & s2 & ","
Else
dic(CStr(j)) = s1 & ","
End If
Next
ReDim gr(1 To n1) As Variant '隣接グラフ
'Group1のk番目の人とマッチ可能なGroup2のメンバーを配列で持つ。
'つまり,一元配列を要素に持つ一次元配列
For k = 1 To n1
ReDim ary(1 To 1)
gr(k) = ary 'Empty配列をセット
Next
'役職条件（役職がひとつでも重なるとNG）に基づき、マッチ可能配列を作成
For j = 1 To n1
s1 = dic(CStr(j))
ary = Split(s1, ",")
For k = n1 + 1 To n
s2 = dic(CStr(k))
matchflag = False
For Each e In ary
If e <> "" Then
If InStr(s2, e & ",") > 0 Then
matchflag = True
Exit For
End If
End If
Next
If matchflag = False Then '重複した役職がなければペア可能
a = gr(j)
If IsEmpty(a(UBound(a))) Then
a(1) = k
Else
ReDim Preserve a(1 To UBound(a) + 1)
a(UBound(a)) = k
End If
gr(j) = a
End If
Next
Next
setData2 = gr
End Function
' 二部マッチングのアルゴリズムを援用（「増加道」を深さ優先探索により求める）
Function dfSearch(person As Long, visited As Object) As Boolean
'以下では、Group2の各メンバーをtaskとみなし、
'Group1のメンバーとtaskの最大マッチングを探すアルゴリズムを援用している。（手抜きとも言う）
Dim i&, task&, w&
For i = 1 To UBound(gr(person))
task = gr(person)(i)
If Not visited.exists(task) Then
visited(task) = Empty
w = matched(task)
If w < 0 Then
matched(task) = person
dfSearch = True
Exit Function
Else
If dfSearch(matched(task), visited) Then
matched(task) = person
dfSearch = True
Exit Function
End If
End If
End If
Next
dfSearch = False
End Function
Function myCount() As Long
Dim c As Long
Dim e As Variant
For Each e In matched
If e <> -1 Then c = c + 1
Next
myCount = c
End Function
'マッチングの結果をシートに反映
Function setColor()
Dim c As Long
Dim p As Long
ws1.[A2].Resize(n1, 1).Copy ws1.[H2]
ws1.[A2].Offset(n1, 0).Resize(n2, 1).Copy
ws1.[I1].PasteSpecial Paste:=xlPasteValues, Transpose:=True
ws1.[I2].Resize(n1, n2).Clear
ws1.[I2].Resize(n1, n2).HorizontalAlignment = xlCenter
ws1.Columns("E:F").ClearContents
[E1] = "member1": [F1] = "member2"
p = 2
For c = n1 + 1 To n1 + n2
If matched(c) > 0 Then
'ペアとなったメンバーの一覧
ws1.Cells(p, "E") = ws1.Cells(matched(c) + 1, "A")
ws1.Cells(p, "F") = ws1.Cells(c + 1, "A")
p = p + 1
'ペアとなったメンバーをクロス表に表示
ws1.Cells(matched(c) + 1, c - n1 + 8) = "〇"
ws1.Cells(matched(c) + 1, c - n1 + 8).Interior.Color = vbYellow '黄色で
End If
Next
End Function
# 2022/7/12 一部修正 （γ） 2022/07/10(日) 21:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.