主题：请教一个排班问题

重复问题：

 

得到的3组数据（早班1个、晚班2个），比如1号可能有重复的人（比如 张三、张三、王五），这个时候，就要交换去重复。

 

如果1号那天，第一个早班和第一个晚班重复，这个时候，把看2、3、4、5.....号晚班的人是否张三（直到找到不是张三的人），交换这两个人。一直往后，可以排除所有重复值。

基本达到设计要求，不过不是每次运行都成功，怎么忽略错误的运算

也就是只出现符合条件的方案，忽略不符合条件的报错

每人的早班数限定为4晚班数限定为7的时候方案就多了，一个月31天的时候必须这么限定

参考代码，看懂代码

 

DataTables("表b").DeleteFor("")
Dim y As Integer = 2018 '指定年
Dim m As Integer = 6 '指定月

Dim days As Integer = Date.DaysInMonth(y,m) '返回指定 年\月 的天数
Dim ed As Date = New Date(y,m,Days)
Dim sd As Date = New Date(y,m,1) '从指定日期开始

Dim zbrys As List(Of String) = DataTables("人员").GetValues("序号","姓名 is not null","_sortkey")

Dim d As Date = sd

Dim dt As DataTable = DataTables("假期")
Dim drs As new Dictionary(of String, Row)
Do While d <= ed
    Dim fdr As DataRow = dt.Find("日期 = #" & d & "#")
    If fdr Is Nothing Then
        Dim nr As Row = Tables("表b").AddNew
        nr("日期") = d
        nr("星期") = Format(d, "dddd")
        drs.add(d, nr)
    Else
        Dim nr As Row = Tables("表b").AddNew
        nr("日期") = d
        nr("星期") = Format(d, "dddd")
        nr("假期") = fdr("说明")
    End If
    d = d.AddDays(1)
Loop
Tables("表b").save
For Each dr As DataRow In DataTables("表b").DataRows
    Dim lst1 As new List(of Integer)
    Select Case dr("星期")
        Case "星期一"
            dr("假期")="1,2"
            lst1.Add(1)
            lst1.Add(2)
        Case "星期二"
            dr("假期")="3,4"
            lst1.Add(3)
            lst1.Add(4)
        Case "星期三"
            dr("假期")="5,6"
            lst1.Add(5)
            lst1.Add(6)
        Case "星期四"
            dr("假期")="7,8"
            lst1.Add(7)
            lst1.Add(8)
        Case "星期五"
            dr("假期")="9,10"
            lst1.Add(9)
            lst1.Add(10)
        Case Else
    End Select
Next
'洗牌填入数据
Dim cnt As Integer = drs.count
Dim ids(cnt - 1) As String
Dim ids1(cnt - 1) As String
Dim ids2(cnt - 1) As String
Dim idx As Integer = 0
Dim i As Integer = 0
For Each key As String In drs.keys
    ids(i) = zbrys(idx)
    ids1(i) = zbrys(idx)
    ids2(i) = zbrys(idx)
    If idx >= zbrys.Count-1 Then
        idx = 0
    Else
        idx+=1
    End If
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids(id1)
    ids(id1) = ids(id2)
    ids(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("早班") = ids(i)
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids1(id1)
    ids1(id1) = ids1(id2)
    ids1(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("晚班") = ids1(i)
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids2(id1)
    ids2(id1) = ids2(id2)
    ids2(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("晚班") &= "," & ids2(i)
    i += 1
Next

'处理重复数据
For Each key As String In drs.keys
    Dim r = drs(key)
    If r("早班") = Nothing Then Continue For
    Dim jq() As String = r("假期").split(",")
    Dim ls As new List(of String)
    If jq.length > 0 Then
        ls.AddRange(jq)
        If array.indexof(jq, r("早班")) >= 0 Then '早班重复
            For Each ckey As String In drs.keys
                If ckey <= r("日期") Then Continue For
                If ls.contains(drs(ckey)("早班")) = False Then
                    Dim temp = r("早班")
                    r("早班") = drs(ckey)("早班")
                    drs(ckey)("早班") = temp
                    Exit For
                End If
            Next
        End If
    End If
    ls.add(r("早班"))
    Dim wb1 = r("晚班").split(",")(0)
    Dim wb2 = r("晚班").split(",")(1)
    If ls.Contains(wb1) Then '第一个晚班重复
        For Each ckey As String In drs.keys
            If ckey <= r("日期") Then Continue For
            Dim cwb1 = drs(ckey)("晚班").split(",")(0)
            Dim cwb2 = drs(ckey)("晚班").split(",")(1)
            If ls.contains(cwb1) = False Then
                r("晚班") = cwb1 & "," & wb2
                drs(ckey)("晚班") = wb1 & "," & cwb2
                Exit For
            End If
        Next
    End If
    wb1 = r("晚班").split(",")(0)
    wb2 = r("晚班").split(",")(1)
    ls.add(wb1)
    If ls.Contains(wb2) Then '第二个晚班重复
        For Each ckey As String In drs.keys
            If ckey <= r("日期") Then Continue For
            Dim cwb1 = drs(ckey)("晚班").split(",")(0)
            Dim cwb2 = drs(ckey)("晚班").split(",")(1)
            If ls.contains(cwb2) = False Then
                r("晚班") = wb1 & "," & cwb2
                drs(ckey)("晚班") = cwb1 & "," & wb2
                Exit For
            End If
        Next
    End If
    wb2 = r("晚班").split(",")(1)
    ls.add(wb2)
    Dim str As String = ""
    For Each s As String In zbrys
        If ls.Contains(s) = False Then
            str &= s & ","
        End If
    Next
    r("正常班") = str.trim(",")
Next

DataTables("表b").save

太好了，简单高效，谢谢老师

老师，我发现当假期列为空时（周末的时候），早晚班还是有重复的

 

请上传具体foxtable实例、代码说明。

此主题相关图片如下：qq截图20180528153832.jpg

下载信息  [文件大小：   下载次数： ]

点击浏览该文件:排班新.table

DataTables("表b").DeleteFor("")

Dim frm As winform.Form = Forms("窗口1")
Dim y As Integer = frm.Controls("ComboBox1").value '指定年
Dim m As Integer = frm.Controls("ComboBox2").value '指定月

Dim days As Integer = Date.DaysInMonth(y,m) '返回指定 年\月 的天数
Dim ed As Date = New Date(y,m,Days)
Dim sd As Date = New Date(y,m,1) '从指定日期开始
Dim zbrys As List(Of String) = DataTables("人员").GetValues("序号","姓名 is not null","_sortkey")
Dim d As Date = sd
Dim dt As DataTable = DataTables("假期")
Dim drs As new Dictionary(of String, Row)
Do While d <= ed
    Dim fdr As DataRow = dt.Find("日期 = #" & d & "#")
    If fdr Is Nothing Then
        Dim nr As Row = Tables("表b").AddNew
        nr("日期") = d
        nr("星期") = Format(d, "dddd")
        drs.add(d, nr)
    Else
        Dim nr As Row = Tables("表b").AddNew
        nr("日期") = d
        nr("星期") = Format(d, "dddd")
        nr("假期") = fdr("说明")
    End If
    d = d.AddDays(1)
Loop
Tables("表b").save
For Each dr As DataRow In DataTables("表b").DataRows
    Dim lst1 As new List(of Integer)
    Select Case dr("星期")
        Case "星期一"
            dr("假期")="1,2"
            lst1.Add(1)
            lst1.Add(2)
        Case "星期二"
            dr("假期")="3,4"
            lst1.Add(3)
            lst1.Add(4)
        Case "星期三"
            dr("假期")="5,6"
            lst1.Add(5)
            lst1.Add(6)
        Case "星期四"
            dr("假期")="7,8"
            lst1.Add(7)
            lst1.Add(8)
        Case "星期五"
            dr("假期")="9,10"
            lst1.Add(9)
            lst1.Add(10)
        Case Else
    End Select
Next

label1:
'洗牌填入数据
Dim cnt As Integer = drs.count
Dim ids(cnt - 1) As String
Dim ids1(cnt - 1) As String
Dim ids2(cnt - 1) As String
Dim idx As Integer = 0
Dim i As Integer = 0
For Each key As String In drs.keys
    ids(i) = zbrys(idx)
    ids1(i) = zbrys(idx)
    ids2(i) = zbrys(idx)
    If idx >= zbrys.Count-1 Then
        idx = 0
    Else
        idx+=1
    End If
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids(id1)
    ids(id1) = ids(id2)
    ids(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("早班") = ids(i)
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids1(id1)
    ids1(id1) = ids1(id2)
    ids1(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("晚班") = ids1(i)
    i += 1
Next
For j As Integer = 0 To cnt \ 2 '洗牌次数
    Dim id1 As Integer = rand.Next(0,cnt)
    Dim id2 As Integer = rand.Next(0,cnt)
    Dim vid As Integer = ids2(id1)
    ids2(id1) = ids2(id2)
    ids2(id2) = vid
Next
i = 0
For Each key As String In drs.keys
    drs(key)("晚班") &= "," & ids2(i)
    i += 1
Next
'处理重复数据
For Each key As String In drs.keys
    Dim r = drs(key)
    If r("早班") = Nothing Then Continue For
    Dim jq() As String = r("假期").split(",")
    Dim ls As new List(of String)
    If jq.length > 0 Then
        ls.AddRange(jq)
        If array.indexof(jq, r("早班")) >= 0 Then '早班重复
            Dim flag = False
            For Each ckey As String In drs.keys
                If ckey <= r("日期") Then Continue For
                If ls.contains(drs(ckey)("早班")) = False Then
                    Dim temp = r("早班")
                    r("早班") = drs(ckey)("早班")
                    drs(ckey)("早班") = temp
                    flag = True
                    Exit For
                End If
            Next
            If flag = False Then '不能处理,重新生成
                goto label1
            End If
        End If
    End If
    ls.add(r("早班"))
    Dim wb1 = r("晚班").split(",")(0)
    Dim wb2 = r("晚班").split(",")(1)
    If ls.Contains(wb1) Then '第一个晚班重复
        Dim flag = False
        For Each ckey As String In drs.keys
            If ckey <= r("日期") Then Continue For
            Dim cwb1 = drs(ckey)("晚班").split(",")(0)
            Dim cwb2 = drs(ckey)("晚班").split(",")(1)
            If ls.contains(cwb1) = False Then
                r("晚班") = cwb1 & "," & wb2
                drs(ckey)("晚班") = wb1 & "," & cwb2
                flag = True
                Exit For
            End If
        Next
        If flag = False Then '不能处理,重新生成
            goto label1
        End If
    End If
    wb1 = r("晚班").split(",")(0)
    wb2 = r("晚班").split(",")(1)
    ls.add(wb1)
    If ls.Contains(wb2) Then '第二个晚班重复
        Dim flag = False
        For Each ckey As String In drs.keys
            If ckey <= r("日期") Then Continue For
            Dim cwb1 = drs(ckey)("晚班").split(",")(0)
            Dim cwb2 = drs(ckey)("晚班").split(",")(1)
            If ls.contains(cwb2) = False Then
                r("晚班") = wb1 & "," & cwb2
                drs(ckey)("晚班") = cwb1 & "," & wb2
                flag = True
                Exit For
            End If
        Next
        If flag = False Then '不能处理,重新生成
            goto label1
        End If
    End If
    wb2 = r("晚班").split(",")(1)
    ls.add(wb2)
    Dim str As String = ""
    For Each s As String In zbrys
        If ls.Contains(s) = False Then
            str &= s & ","
        End If
    Next
    r("正常班") = str.trim(",")
Next

DataTables("表b").save