以文本方式查看主题

-  Foxtable(狐表)  (http://www.foxtable.com/bbs/index.asp)
--  专家坐堂  (http://www.foxtable.com/bbs/list.asp?boardid=2)
----  超过10组的分组分道问题  (http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&id=46166)

--  作者:aygp
--  发布时间:2014/2/18 11:20:00
--  超过10组的分组分道问题

y2287958老师设计的分组分道效果非常好,但是超过10组就只能分组不能分道了,如果超过10组也可以继续分道,代码应该如何修改?

 

 下载信息  [文件大小:   下载次数: ]
图片点击可在新窗口打开查看点击浏览该文件:分组分道(超过10组).rar


--  作者:aygp
--  发布时间:2014/2/18 17:13:00
--  
y2287958老师请改一改代码,谢谢了!
--  作者:有点甜
--  发布时间:2014/2/18 20:17:00
--  
 呃,表A在哪里?附上数据源
--  作者:y2287958
--  发布时间:2014/2/19 8:07:00
--  
代码中“8”改成“10”基本解决问题
类似问题,软件只能分类到一定程度,最后还是要人工再优化一下的。

--  作者:aygp
--  发布时间:2014/2/19 11:23:00
--  

代码中“8”改成“10”后就变成每组10 道了,运动场的跑道最多只有8道。还有一个很重要的问题需要解决,因为在“项目”列中有很多运动项目,如1500米、3000米、跳高、跳远、铅球等都不需要分道。所以我希望只对筛选出来的项目如100M进行分组分道,没有筛选出来的项目就不进行分组分道。也就是目前要解决二个问题。1、超过10组的分组分道(最多只能8道);2、只对筛选出来的项目进行分组分道。第二个问题很重要。

见带数据库附件:

 下载信息  [文件大小:   下载次数: ]
图片点击可在新窗口打开查看点击浏览该文件:分组分道(超过10组带数据库).rar


--  作者:有点甜
--  发布时间:2014/2/19 22:27:00
--  
 代码改成这样

Dim ss As List(of String) = DataTables("表A").GetValues("项目", Tables("表A").Filter)
For Each s As String In ss
    Dim drs As List(of DataRow) = DataTables("表A").Select("项目=\'" & s & "\' and " & Tables("表A").Filter, "单位")
    drs(0)("预赛组别") = 1
    For i As Integer = 1 To drs.Count - 1
        Dim i1 As Integer = drs(i-1)("预赛组别")
        If i1 >= Math.Ceiling(drs.Count/8)
            For i2 As Integer = 1 To 8
                Dim i3 As Integer = DataTables("表A").Compute("Count(项目)","项目=\'" & s & "\' and 预赛组别=\'" & i2 & "\' and " & Tables("表A").Filter)
                If i3 < Math.Ceiling(drs.Count/8)
                    drs(i)("预赛组别") = 1
                Else
                    drs(i)("预赛组别") = i3
                End If
            Next
        Else
            drs(i)("预赛组别") = i1 + 1
        End If
    Next
Next

For Each s As String In ss
    Dim ss1 As List(of String) = DataTables("表A").GetValues("预赛组别","项目=\'" & s & "\' and " & Tables("表A").Filter)
    For Each s1 As Integer In ss1
        \' Dim drs As List(of DataRow) = DataTables("表A").Select("项目=\'" & s & "\'and 预赛组别=" & s1,"单位")
        Dim drs As List(of DataRow) = DataTables("表A").Select("项目=\'" & s & "\'and 预赛组别=\'" & s1 & "\' and " & Tables("表A").Filter,"单位")
        drs(0)("预赛道次") = 1
        For i As Integer = 1 To drs.Count - 1
            drs(i)("预赛道次") = drs(i-1)("预赛道次") + 1
        Next
        For i As Integer = 1 To drs.Count - 1
            If drs(i)("单位") = drs(i-1)("单位")
                If (i-4)>=0
                    drs(i)("预赛道次") =  i-4+1
                    drs(i-4)("预赛道次") = i+1
                ElseIf (i+4)<=drs.Count
                    drs(i)("预赛道次") =  i+4+1
                    drs(i+4)("预赛道次") = i+1
                End If
            End If
        Next
    Next
Next
Tables("表A").Sort = "项目,预赛组别,预赛道次"

清除跑道的代码

DataTables("表A").ReplaceFor("预赛组别",Nothing,Tables("表A").Filter)
DataTables("表A").ReplaceFor("预赛道次",Nothing,Tables("表A").Filter)

--  作者:aygp
--  发布时间:2014/2/20 0:47:00
--  
测试成功,谢谢甜老师!
--  作者:lsy
--  发布时间:2014/2/20 8:34:00
--  

6楼的代码,在Table("表A").Filter = ""  的时候,会报错。

稍改一下:

Dim ss As List(of String) = DataTables("表A").GetValues("项目", Tables("表A").Filter)
Dim flt As String
If Tables("表A").Filter > "" Then
    flt = " And " & Tables("表A").Filter
Else
    flt = ""
End If
For Each s As String In ss
    Dim drs As List(Of DataRow) = DataTables("表A").Select("项目 = \'" & s & "\'" & flt,"单位")
    drs(0)("预赛组别") = 1
    For i As Integer = 1 To drs.Count - 1
        Dim i1 As Integer = drs(i - 1)("预赛组别")
        If i1 >= Math.Ceiling(drs.Count / 8)
            For i2 As Integer = 1 To 8
                Dim i3 As Integer = DataTables("表A").Compute("Count(项目)","项目 = \'" & s & "\' and 预赛组别 = \'" & i2 & "\'" & flt)
                If i3 < Math.Ceiling(drs.Count / 8)
                    drs(i)("预赛组别") = 1
                Else
                    drs(i)("预赛组别") = i3
                End If
            Next
        Else
            drs(i)("预赛组别") = i1 + 1
        End If
    Next
Next
For Each s As String In ss
    Dim ss1 As List(of String) = DataTables("表A").GetValues("预赛组别","项目 = \'" & s & "\'" & flt)
    For Each s1 As Integer In ss1
        Dim drs As List(of DataRow) = DataTables("表A").Select("项目 = \'" & s & "\'and 预赛组别=\'" & s1 & "\'" & flt,"单位")
        drs(0)("预赛道次") = 1
        For i As Integer = 1 To drs.Count - 1
            drs(i)("预赛道次") = drs(i - 1)("预赛道次") + 1
        Next
        For i As Integer = 1 To drs.Count - 1
            If drs(i)("单位") = drs(i - 1)("单位")
                If (i - 4)>=0
                    drs(i)("预赛道次") =  i - 4 + 1
                    drs(i - 4)("预赛道次") = i + 1
                ElseIf (i + 4) <= drs.Count
                    drs(i)("预赛道次") = i + 4 + 1
                    drs(i + 4)("预赛道次") = i + 1
                End If
            End If
        Next
    Next
Next
Tables("表A").Sort = "项目,预赛组别,预赛道次"


--  作者:aygp
--  发布时间:2014/2/20 11:38:00
--  
谢谢lsy老师!
--  作者:aygp
--  发布时间:2014/2/20 12:19:00
--  
lsy老师的代码也需要修改。6楼的代码在运行时,如果没有筛选就按“分组分道”按键,会跳出一个出错窗口,现在只需要把窗口中的内容修改为:“请选择比赛项目再分组分道”的提示,就非常完美了,用户根据提示再重新操作。