[[20190108180846]]　『レコード数がなるべく均等になるように分割を行う』（dai）　ページの最後に飛ぶ

『レコード数がなるべく均等になるように分割を行う方法について』（dai）

A列　　 B列　　　 C列
コード　氏名　　　担当者
1　　　田中太郎　A
1　　　田中太郎　A
2　　　山田次郎　A
2　　　山田次郎　A
2　　　山田次郎　A
3　　　鈴木三郎　B
3　　　鈴木三郎　B
3　　　鈴木三郎　B
3　　　鈴木三郎　B
4　　　佐藤四郎　C
4　　　佐藤四郎　C
5　　　加藤五郎　C
5　　　加藤五郎　C
5　　　加藤五郎　C
5　　　加藤五郎　C
5　　　加藤五郎　C
6　　　小川六郎　D
6　　　小川六郎　D
7　　　中村七郎　D
7　　　中村七郎　D

上記データは、A列「コード」・B列「氏名」のデータを、４名の担当者に
対してなるべくレコード数が均等になるように割り振りを行ったものですが、
割り振りの際、一つのコードのグループは必ず１担当者だけに割り振られる
ように割り振りを行っています。

こうしたレコードの割り振りをVBAまたは関数により行う適当な方法があれば、
ヒントをご教示頂けると幸いです。
よろしくお願いいたします。

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

コードが例の通り連番なら
=CHOOSE(MOD(A2,4)+1,"A","B","C","D")

（マナ） 2019/01/08(火) 18:37

早速のご回答、ありがとうございます。
すみません、実際のデータでは、コードは5桁コードで連番ではありません。
（実データのコード部分
A列
40325
40325
40360
40360
40360
40385
40385
40385
40385
40415
40415
・
・

（dai） 2019/01/08(火) 19:58

では.連番を作成すればよいのでは？

（マナ） 2019/01/08(火) 20:26

たびたび大変申し訳ありません。
条件が不足しておりました。
上記の担当者の割り当ては上のレコードから順番に
A→B→C→Dの順で割り当てる必要があります。
ご教示頂いたCHOOSE関数を用いたやり方ですと、
この順序がランダムになってしまいます。
（dai） 2019/01/08(火) 20:34

わたしの関数の知識では無理なので
手作業で、ささっとやってしまいそうです。
他の方の回答をお待ち下さい。

（マナ） 2019/01/08(火) 20:46

 C1セル =COUNT(A:A)　
 　　　　　　↑
 こういうのをC2の数式に組み入れるのは無駄すぎるので、一つのセルだけ使って計算しておく。

 数字じゃ格好悪いと言うことなら、セルの書式(表示形式）で、
 "担当者"　とユーザー定義して、見せかけだけ「担当者」にする。

 C2セル =IF(A2="","",IF(A2=A1,C1,CHOOSE(MATCH(ROW()-1,ROUND(C$1/4*{0,1,2,3},0)),"A","B","C","D")))

 下にコピー

（半平太） 2019/01/08(火) 22:41

Sub main()

    Dim dt(1 To 4) As String, dic As Object, k As Variant, x As Long, i As Long, p As Long, targetp As Long, t_a As Long, t_b As Long, t_c As Long, t_d As Long, r As Range
    x = WorksheetFunction.Round(WorksheetFunction.CountA(Range("B2:B" & Rows.Count)) / 4, 0)
    Set dic = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    dt(1) = "A": dt(2) = "B": dt(3) = "C": dt(4) = "D"
    Range("C:C").ClearContents
    Application.ScreenUpdating = False
    Do While p < 1000
        Range("C:C").ClearContents
        i = 1
        Set r = Range("C2")
            Do While r.Offset(, -1).Value <> ""
                r.Value = dt(i)
                   If WorksheetFunction.CountIf(Range("C:C"), dt(i)) < x * 2 And Rnd > 0.8 And r.Offset(, -2).Value <> r.Offset(1, -2).Value Then
                    i = i + 1
                    If i > 4 Then Exit Do
                End If
                Set r = r.Offset(1)
            Loop
        t_a = WorksheetFunction.CountIf(Range("C2:C" & Rows.Count), "A")
        t_b = WorksheetFunction.CountIf(Range("C2:C" & Rows.Count), "B")
        t_c = WorksheetFunction.CountIf(Range("C2:C" & Rows.Count), "C")
        t_d = WorksheetFunction.CountIf(Range("C2:C" & Rows.Count), "D")
        If t_a * t_b * t_c * t_d > 0 And WorksheetFunction.CountA(Range("B2:B" & Rows.Count)) = WorksheetFunction.CountA(Range("C2:C" & Rows.Count)) Then
            dic(p) = (WorksheetFunction.Max(t_a, t_b, t_c, t_d) - WorksheetFunction.Min(t_a, t_b, t_c, t_d))
            dic2(p) = t_a & "," & t_b & "," & t_c & "," & t_d
        End If
    p = p + 1
    Loop
    Application.ScreenUpdating = True
    targetp = WorksheetFunction.CountA(Range("B2:B" & Rows.Count))
    For Each k In dic
       If dic(k) < targetp Then targetp = dic(k): targetk = k
    Next k
    Set r = Range("C2")
     comm = Array("A", "B", "C", "D")
    For x = 0 To 3
        For p = 1 To Split(dic2(targetk), ",")(x)
            r.Value = comm(x)
            Set r = r.Offset(1)
        Next p
    Next x
End Sub
（mm） 2019/01/09(水) 18:20

皆さま、本当にありがとうございました。
取り急ぎ半平太様の関数を使う方法で対応しましたが、
VBAの方も確認させていただきたいと思います。
（dai） 2019/01/11(金) 11:00

コメント返信：

[ 一覧(最新更新順) ]

[[20190108180846]] 『レコード数がなるべく均等になるように分割を行う』（dai） ページの最後に飛ぶ

[[20190108180846]]　『レコード数がなるべく均等になるように分割を行う』（dai）　ページの最後に飛ぶ