[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『自動で振り分け』（>_<）
お世話になります。
Sheet2に下記のようなグループ分けした表があります。
Sheet2のリストからSheet1の表の同じ作業項目の下のセルに氏名が順に振り分けを行うことは出来ますでしょうか？
重複する場合は下記の人へ移り、該当者がいない場合は空白といった感じです。
無茶な気はするのですが、どうかお知恵をお貸し下さい。
Sheet2の表
作業A 作業B 作業C 作業E
A氏 A氏 D氏 D氏
B氏 B氏 E氏 E氏
C氏 C氏 F氏 G氏
D氏
Sheet1の表(都度変更あり)
希望の完成型
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
（γ） 2021/10/01(金) 21:42
Sheet1の表(都度変更あり)
作業A 作業B 作業C 作業E
作業A 作業B
作業B 作業C
希望の完成型
作業A 作業B 作業C 作業E
A氏 B氏 D氏 E氏
作業A 作業B
C氏 空白
作業B 作業C
空白 F氏
（>_<） 2021/10/01(金) 22:40
作業A 作業B 作業C 作業E A氏 B氏 E氏 G氏 作業A 作業B C氏 空白 作業B 作業C D氏 F氏 じゃだめな理由はなんですか？こちらは7人が稼働しますけど。 あなたの例示をとった理由、理屈ですかね、それを教えてください。 いまだにルールがわかりません。
（γ） 2021/10/01(金) 23:21
Sub test()
Dim dic1 As Object
Dim dic2 As Object
Dim r As Range, c As Range
Dim k As Long, j As Long
Dim 作業 As String, 氏名 As String
Set dic1 = CreateObject("scripting.dictionary")
Set r = Worksheets("Sheet2").Cells(1).CurrentRegion
For Each c In r.Columns
作業 = c.Cells(1).Value
Set dic1(作業) = CreateObject("system.collections.queue")
For k = 1 To c.Cells.Count
氏名 = c.Cells(k).Value
If 氏名 = "" Then Exit For
dic1(作業).enqueue 氏名
Next
Next
Set dic2 = CreateObject("scripting.dictionary")
With Worksheets("Sheet1")
For k = 1 To .Cells(Rows.Count, 1).End(xlUp).Row Step 2
For j = 1 To .Cells(k, Columns.Count).End(xlToLeft).Column
作業 = .Cells(k, j).Value
Do
氏名 = ""
If Not dic1.exists(作業) Then Exit Do
If dic1(作業).Count = 1 Then Exit Do
氏名 = dic1(作業).dequeue
If Not dic2.exists(氏名) Then Exit Do
Loop
dic2(氏名) = True
Cells(k + 1, j).Value = 氏名
Next
Next
End With
End Sub
（マナ） 2021/10/01(金) 23:24 差し替え23:58
じゃだめな理由はなんですか？こちらは7人が稼働しますけど
ほんと、そうですね。
（マナ） 2021/10/02(土) 00:04
（マナ） 2021/10/02(土) 00:24
これは例示なんでしょうね。
実際のデータはどのくらいの大きさなのか。
チラシの裏にメモしただけですが、
ソルバーを使うと良いのかも。
質問者さんからコメントがあるでしょう。
（γ） 2021/10/02(土) 00:34
（>_<） 2021/10/02(土) 00:45
縦方向が作業内容
一覧はその作業が出来る人
つまり、列で作業員の氏名が重複しないように自動で割り振りしたいのかなと。。。
ただ、そうすると、作業が出来る人がりないと待ちになり、列をずらしたりが出てきますね。
あと、作業時間も作業それぞれが同じではないだろうと思われるので、
自動化はかなり難易度が高くなるかと。（VBAの知識がなければの話）
考え方はそんなに難しくないので、
画面の設計をエクセルの数式で表示しやすいようにつくれば、
空いている人を探して協調表示するくらいなら出来るのではないでしょうか？
いずれにしてもアイデアしだいかと。
エクセルの使い方を知らなければアイデアもでないでしょうが。。。
（まっつわん） 2021/10/02(土) 08:51
あらためて確認ですが、以下の問題と考えていいですか？ 『作業1から作業4まであり、 それぞれの作業を担当できる人に○をつけています。 それぞれの作業の必要人数が、最下段の数値であるとき、 どのような割当が最適でしょうか。 』 という問題ということでよいのでしょうか。
作業1 作業2 作業3 作業4
A氏 ○ ○
B ○ ○
C ○
D ○ ○ ○ ○
E ○ ○
F ○
G ○
必要人数 2 3 2 1
これは目の子で簡単に、
作業1 作業2 作業3 作業4
A氏 ● ○
B ○ ●
C ●
D ○ ● ○ ○
E ● ○
F ●
G ●
だろうと察しがつきます。（一意ではないですもちろん）
コードで作っていくこともできるかもしれません。 選択肢の少ない人（例えばGさん）から優先的に 決めていくようなことを考えればよいのかもしれません。
------------------------- Excelにあるソルバーを使う手もあるかもしれません。 （ただし、予め書きますが、 目的変数は上限200、制約条件は上限100という制限があります）
A列 B列 C D E F
1 作業1 作業2 作業3 作業4
2 A氏 1 0 0 0
3 B 0 1 0 0
4 C 1 0 0 0
5 D 0 1 0 0
6 E 0 0 1 0
7 F 0 0 1 0
8 G 0 0 0 1
9 必要数2 3 2 1
10 2 2 2 1
（式の内容）
・10行目には各列それぞれ、2行目から8行目の合計
・F列には、各行の横計
・F7 = SUM(B7:E7)
（ソルバー）
・目的セル F7 を最大にするよう設定
・変数セル B2:E8
・制約条件
B2:E8 バイナリ(0か1の値という意味）
B10<＝B9 などの人数要件
F2:F8 <= 1 (各人は一つの作業しか同時にできない）
D2:E4 = 0 (資格なしのところ（複数）は予め強制的に0とする）
・使用アルゴリズム（シンプレックスLPでよいと思います）
（γ） 2021/10/02(土) 10:11
（>_<） 2021/10/02(土) 15:13
（γ） 2021/10/02(土) 15:52
| ちなみにSheet2の実際のデータは200人150種類位の作業になります。 | Sheet1の作業は10ライン程度で１ライン10〜20作業程度でしょうか。 担当者数はどのくらいですか？ 仮に、 １０ライン１ライン15とすると作業は150。 従業員が仮に50人としても、 ソルバー使用にあたっての変化させるセルは 150 * 50 =7500 となり、 Excelのソルバーでは変化させるセルの上限は200個なので、 完全にこれを超えますので、ソルバーでは対応不可能ですね。 （なお、上記の制限の記述において目的変数の制約200個と書いたのは間違いです。 変動させる変数の制約です。）
上記の実際の件数からすると、手作業ではどうにもならないはずで、 現在はどうされているのですか？ 何かしらのシステム的なサポートがあるのでは？ それか、殆どの従業員の担当範囲が比較的広く、 単に上から並べて言っても、問題は生じないという状況なのかもしれません。
（γ） 2021/10/03(日) 07:49
いわゆる二部マッチングという議論にもちこめそうなので、
コードにトライできるかもしれません。
最大フローを求める問題に帰着される問題で、
結構この手の問題では有名なものらしいですね。
参考：
https://qiita.com/drken/items/e805e3f514acceb87602
興味をお持ちのかたは是非トライしてみて下さい。
（γ） 2021/10/05(火) 09:59
■参照サイト https://qiita.com/drken/items/e805e3f514acceb87602 にも書かれていますが、こうしたテーマについては、 大きく二つの手法があります。 (1)ネットワークフローアルゴリズム、あるいは類似のアルゴリズムを用いる (2)数理最適化ソルバーを用いる
■私が最初に言及したのは、(2)の方法です。 （しかし、Excelのソルバーは変数の個数等の制限があり、対応不能かと思います。 一般的な数理最適化ソルバーを使用すれば、たぶん解決可能だと思いますが、 質問者さんの環境には無いと思われるので、無理かと思いました。） Excelのソルバー案については、既に考え方を示しましたので、 それを理解されるのが先で、私が追加で何かをするとは考えていませんでした。 そもそも制約があることも分かっていましたし。
■その後、少し時間を置いて考えたところ、(1)の手法もありそうなことが分かりました。
A氏 と 作業A の間には"割当可能"のいう複数の関係があります。
B氏 作業B
C氏 作業C
D氏 作業E
E氏 作業A
F氏 作業B
G氏 作業B
作業C
その割当可能な組み合わせの中から、作業を割り当てることとし、 ・各人にはひとつの作業を割当て、 ・しかも、同一の作業に複数の人が重ならないようにする （作業は複数人を要するものがあるので、その数だけの作業を列挙してあります） そのようなマッチングを考えます。
それらの多数あるマッチングのうち、個数最大のものを選ぶ、 という問題になるものと思います。
これは「二部マッチング」問題と呼ばれているようです。（参照サイトに説明があります）
このアルゴリズムが作成できれば、数の制約は殆どなくなるように思いますし、 質問者さんの要望に応えることができるかもしれません。 （むろん実行時間は相当掛かるとは思いますが。） （γ） 2021/10/07(木) 00:05
ワークシートの前提と、使用するコードを以下に示します。
<<割当可能表>> 作業A 作業B 作業C 作業E A氏 A氏 D氏 D氏 B氏 B氏 E氏 E氏 C氏 C氏 F氏 G氏 D氏
<<割当表>>(マクロ実行前）これは事前に用意してください。
A列 B C D E F G H I 1 作業A 作業B 作業C 作業E 作業A 作業B 作業B 作業C 2 A氏 3 B氏 4 C氏 5 D氏 6 E氏 7 F氏 8 G氏
担当
<<割当表>>(マクロ実行後、こうなります） A列 B C D E F G H I 1 作業A 作業B 作業C 作業E 作業A 作業B 作業B 作業C 2 A氏 ○ ○ ○ ● ○ 3 B氏 ○ ○ ● ○ ○ 4 C氏 ○ ● ○ ○ ○ 5 D氏 ● ○ ○ ○ ○ 6 E氏 ● ○ ○ 7 F氏 ○ ● 8 G氏 ●
担当 D氏 C氏 E氏 G氏 B氏 A氏 F氏 ●の代わりに黄色で塗りつぶしています。
■マクロの動かし方 ・標準モジュールに下記をコピーペイストしてください。
なお、実際のデータが提供されないこともあって、 テストが不十分ですので、上手く動作しないこともありえます。
Option Explicit
Dim ws1 As Worksheet Dim ws2 As Worksheet Dim numOfPerson As Long Dim numOfTasks As Long Dim visited As Object Dim matched() As Long Dim g() As Variant 'グラフの隣接リスト（その人は、どのタスクに割当可能か）
Sub main()
Dim res As Long
Dim k As Long
Dim v As Long
Call setData 'グラフの構築
ReDim matched(1 To numOfTasks) As Long 'そのタスクが誰に割当られているか
For k = 1 To numOfTasks
matched(k) = -1
Next
Set visited = CreateObject("Scripting.Dictionary")
For v = 1 To numOfPerson
visited.RemoveAll
If dfs(v, visited) Then
res = res + 1
End If
Next
Debug.Print res ' 最大マッチングの個数
Call setColor ' 結果を"割当表"シートに反映
End Sub
Sub setData()
Dim dic As Object
Dim myRange As Range
Dim header As Range
Dim body As Range
Dim e As Range
Dim rng2 As Range
Dim k&, r&, c&
Dim s$
Dim a As Variant
Set ws1 = Worksheets("割当可能表")
Set ws2 = Worksheets("割当表")
Set dic = CreateObject("Scripting.Dictionary")
'(1)担当者が可能な作業の内容を dicに保持
Set myRange = ws1.[A1].CurrentRegion
Set header = myRange.Rows(1).Cells
Set body = Intersect(myRange, myRange.Offset(1))
For Each e In body
If e <> "" Then dic(e & vbTab & header(1, e.Column)) = Empty
Next
'(2)各担当者と 必要な各作業を頂点としたグラフの
'隣接リストを g に保持する
Set rng2 = ws2.[A1].CurrentRegion
rng2.Interior.Pattern = xlNone
numOfPerson = rng2.Rows.Count - 1
numOfTasks = rng2.Columns.Count - 1
ReDim g(1 To numOfPerson) As Variant '隣接グラフ
'k番目の人の割当可能なタスク(1〜numOfTasksの要素)を配列で持つ
For k = 1 To numOfPerson
ReDim ary(1 To 1)
g(k) = ary
Next
For r = 1 To numOfPerson
For c = 1 To numOfTasks
s = ws2.Cells(r + 1, 1) & vbTab & ws2.Cells(1, c + 1)
If dic.exists(s) Then
ws2.Cells(r + 1, c + 1) = "○"
a = g(r)
If IsEmpty(a(UBound(a))) Then
a(1) = c
Else
ReDim Preserve a(1 To UBound(a) + 1)
a(UBound(a)) = c
End If
g(r) = a
End If
Next
Next
End Sub
Function dfs(v As Long, visited As Object) As Boolean '"増加道"を深さ優先で探索
Dim i&, u&, w&
For i = 1 To UBound(g(v))
u = g(v)(i)
If Not visited.exists(u) Then
visited(u) = Empty
w = matched(u)
If w < 0 Then
matched(u) = v
dfs = True
Exit Function
Else
If dfs(matched(u), visited) Then
matched(u) = v
dfs = True
Exit Function
End If
End If
End If
Next
dfs = False
End Function
'マッチングの結果を"割当表"シートに反映（黄色塗りつぶしとともに担当者名を記入）
Function setColor()
Dim c As Long
ws2.Rows(numOfPerson + 3).ClearContents
For c = 1 To numOfTasks
If matched(c) > 0 Then
'黄色で塗りつぶし
ws2.Cells(matched(c) + 1, c + 1).Interior.Color = vbYellow
'欄外に担当者名を記入
ws2.Cells(numOfPerson + 3, c + 1) = ws2.Cells(matched(c) + 1, "A")
End If
Next
End Function
なおアルゴリズムの詳細は https://ikatakos.com/pot/programming_algorithm/graph_theory/bipartite_matching を参照してください。 （γ） 2021/10/07(木) 00:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.