以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  [求助]点上面的国开教室安排老是计算要很长时间，而且死机，哪位高手有设有更好的计算方法？求助  (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=93779)
--  作者：zgjmost
--  发布时间：2016/12/6 20:47:00
--  [求助]点上面的国开教室安排老是计算要很长时间，而且死机，哪位高手有设有更好的计算方法？求助
[求助]点上面的国开教室安排老是计算要很长时间，而且死机，哪位高手有设有更好的计算方法？求助

http://url.cn/42DL4nG

程序在上面的连接中！

谢谢
--  作者：有点蓝
--  发布时间：2016/12/6 21:52:00
--  
Dim bb As New SQLGroupTableBuilder("国考秩序册","国开课程表")
bb.Groups.AddDef("考试地址")
bb.Groups.AddDef("日期")
bb.Groups.AddDef("时间")
bb.Groups.AddDef("试卷号")
bb.Groups.AddDef("保密号")
bb.Totals.AddExp("人数","1")
bb.Build
MainTable = Tables("国考秩序册")
Output.Show(Date.Now)
For Each arrr As DataRow In DataTables("国考秩序册").Select("试卷号 is not null")
    
    Dim ar3 As DataRow
    ar3 = DataTables("国开秩序安排").AddNew()
    ar3("考试地址") = arrr("考试地址")
    ar3("日期") = arrr("日期")
    ar3("时间") = arrr("时间")
    ar3("试卷号") = arrr("试卷号")
    ar3("保密号") = arrr("保密号")
    ar3("人数") = arrr("人数")

        Dim dr11 As DataRow
    If ar3.IsNull("保密号") = False Then
        dr11 = DataTables("国开课程表").find("保密号 = \'" & ar3("保密号") & "\'")
    Else
        dr11 = DataTables("国开课程表").find("试卷号 = \'" & ar3("试卷号") & "\'")
    End If
    If dr11 IsNot Nothing Then
        ar3("考试地址") = dr11("考试地址")
        ar3("试卷名称") = dr11("试卷名称")
        ar3("考试类型") = dr11("考试类型")
        ar3("短日期") = dr11("短日期")
        ar3("考场号") = dr11("考场号")
        ar3("是否留考") = dr11("是否留考")
        ar3("考场号") = dr11("考场号")
        ar3("起始时间") = dr11("起始时间")
        ar3("结束时间") = dr11("结束时间")
        ar3("时长") = dr11("时长")
    End If
Next

Output.Show(Date.Now)
Tables("国开秩序安排").Sort = "短日期,起始时间,人数"

Dim Book2 As New XLS.Book(ProjectPath & "Attachments\\国考秩序安排教室.xls ")
Dim fl1 As String = ProjectPath & "Reports\\国考秩序供安排之用教室.xls"
Book2.Build() \'生成细节区
Book2.Save(fl1) \'保存工作簿
Output.Show(Date.Now)
Forms("国考考场编排建议").OPEN
--  作者：zgjmost
--  发布时间：2016/12/7 6:44:00
--  
你这个代码没改变
你试过吗？
--  作者：zgjmost
--  发布时间：2016/12/7 7:36:00
--  
Dim cls As List(Of DataRow) = DataTables("可供安排的教室").Select("", "优先使用顺序")

Dim dt As DataTable = DataTables("国开秩序安排")
dt.ResumeRedraw
dt.StopRedraw

\'尽量不要一次性计算全部,因为运算是很慢的
Dim rqsjs As List(Of String()) = dt.GetValues("考试地址|日期|时间")
For Each rqsj() As String In rqsjs
    vars("cidx") = 0
    Dim filter As String = "考试地址 = \'" & rqsj(0) & "\' and 日期 = \'" & rqsj(1) & "\' and 时间 = \'" & rqsj(2) & "\'"
    Dim drs As List(Of DataRow) = dt.Select(filter, "人数 desc")
    Dim Ispick As new List(of Integer)
    Dim b(drs.Count-1) As Integer
    For i As Integer = 1 To drs.Count
        If i <= drs.Count - IsPick.Count Then
            e.Form.Controls("显示").Text = rqsj(0) & " " & rqsj(1) & " " & rqsj(2) & "(" & i & " " & drs.Count & " " & IsPick.count & ")"
            application.DoEvents
            Functions.Execute("组合排列", drs, b.length, i, b, i, cls, IsPick)
        End If
    Next
    Dim left As Integer = cls(vars("cidx"))("最大安排人数")
    For i As Integer = drs.count - 1 To 0 Step -1
        If Ispick.Contains(i) = False Then
            If left >= drs(i)("人数") Then
                drs(i)("教室") = cls(vars("cidx"))("教室名称")
                left -= drs(i)("人数")
            Else
                vars("cidx") += 1
                If cls.Count > vars("cidx") Then
                    left = cls(vars("cidx"))("最大安排人数")
                    drs(i)("教室") = cls(vars("cidx"))("教室名称")
                    left -= drs(i)("人数")
                Else
                    drs(i)("教室") = "教室不够"
                End If
            End If
        End If
    Next
Next
dt.ResumeRedraw

Tables("国开秩序安排").Sort = "考试地址,短日期,起始时间,人数"
   
    Dim Book2 As New XLS.Book(ProjectPath & "Attachments\\国考秩序安排教室.xls ")
    Dim fl1 As String = ProjectPath & "Reports\\国考秩序安排供安排之用(有建议教室安排).xls"
    Book2.Build() \'生成细节区
    Book2.Save(fl1) \'保存工作簿

msgbox("祝贺您!国考教室安排建议计算完毕,实际安排以您的最终安排为准!")
--  作者：zgjmost
--  发布时间：2016/12/7 7:43:00
--  
对程序又进行了优化，但还是计算中断

http://url.cn/42E5X8N

Dim cls As List(Of DataRow) = DataTables("可供安排的教室").Select("", "优先使用顺序")

Dim dt As DataTable = DataTables("国开秩序安排")
dt.ResumeRedraw
dt.StopRedraw

\'尽量不要一次性计算全部,因为运算是很慢的
Dim rqsjs As List(Of String()) = dt.GetValues("考试地址|日期|时间")
For Each rqsj() As String In rqsjs
    vars("cidx") = 0
    Dim filter As String = "考试地址 = \'" & rqsj(0) & "\' and 日期 = \'" & rqsj(1) & "\' and 时间 = \'" & rqsj(2) & "\'"
    Dim drs As List(Of DataRow) = dt.Select(filter, "人数 desc")
    Dim Ispick As new List(of Integer)
    Dim b(drs.Count-1) As Integer
    For i As Integer = 1 To drs.Count
        If i <= drs.Count - IsPick.Count Then
            e.Form.Controls("显示").Text = rqsj(0) & " " & rqsj(1) & " " & rqsj(2) & "(" & i & " " & drs.Count & " " & IsPick.count & ")"
            application.DoEvents
            Functions.Execute("组合排列", drs, b.length, i, b, i, cls, IsPick)
        End If
    Next
    Dim left As Integer = cls(vars("cidx"))("最大安排人数")
    For i As Integer = drs.count - 1 To 0 Step -1
        If Ispick.Contains(i) = False Then
            If left >= drs(i)("人数") Then
                drs(i)("教室") = cls(vars("cidx"))("教室名称")
                left -= drs(i)("人数")
            Else
                vars("cidx") += 1
                If cls.Count > vars("cidx") Then
                    left = cls(vars("cidx"))("最大安排人数")
                    drs(i)("教室") = cls(vars("cidx"))("教室名称")
                    left -= drs(i)("人数")
                Else
                    drs(i)("教室") = "教室不够"
                End If
            End If
        End If
    Next
Next
dt.ResumeRedraw

Tables("国开秩序安排").Sort = "考试地址,短日期,起始时间,人数"
   
    Dim Book2 As New XLS.Book(ProjectPath & "Attachments\\国考秩序安排教室.xls ")
    Dim fl1 As String = ProjectPath & "Reports\\国考秩序安排供安排之用(有建议教室安排).xls"
    Book2.Build() \'生成细节区
    Book2.Save(fl1) \'保存工作簿

msgbox("祝贺您!国考教室安排建议计算完毕,实际安排以您的最终安排为准!")

主要是上面这段代码能不能优化？
--  作者：zgjmost
--  发布时间：2016/12/7 7:43:00
--  

自定义函数

 

组合排列

 

Dim a As object = args(0)

Dim n As Integer = args(1)

Dim m As Integer = args(2)

Dim b() As Integer = args(3)

Dim Mm As Integer = args(4)

Dim cls As object = args(5)

Dim IsPick As Object = args(6)

 

For i As Integer = n To m Step -1

    If IsPick.Contains(i-1) = False Then

        b(m-1) = i-1

        If m > 1 Then

            Functions.Execute("组合排列", a, i-1, m-1, b, Mm, cls, IsPick)

        Else

            Dim sum As Double = 0

            For j As Integer = 0 To Mm - 1

                If IsPick.Contains(b(j)) Then Return Nothing

                sum += a(b(j))("人数")

            Next

            If sum = cls(vars("cidx"))("最大安排人数") Then

                For j As Integer = Mm - 1 To 0 Step -1

                    a(b(j))("教室") = cls(vars("cidx"))("教室名称")

                    IsPick.add(b(j))

                Next

                vars("cidx") += 1

            End If

        End If

    End If

Next

 

全局代码

 

Default

 

Public delimg As Image = GetImage("del.png")

 还有上面这个能不能优化下！
--  作者：有点蓝
--  发布时间：2016/12/7 8:23:00
--  
我以为你是说菜单按钮的计算慢，原来是窗口的计算按钮事件慢。

麻烦详细描述一下按钮的整个整个计算逻辑，或者说说按什么规则来安排教室
--  作者：zgjmost
--  发布时间：2016/12/7 9:35:00
--  
Dim cls As List(Of DataRow) = DataTables("可供安排的教室").Select("", "优先使用顺序")

Dim dt As DataTable = DataTables("国开秩序安排")
dt.ResumeRedraw
dt.StopRedraw

\'尽量不要一次性计算全部,因为运算是很慢的
Dim rqsjs As List(Of String()) = dt.GetValues("考试地址|日期|时间")
For Each rqsj() As String In rqsjs
    vars("cidx") = 0
    Dim filter As String = "考试地址 = \'" & rqsj(0) & "\' and 日期 = \'" & rqsj(1) & "\' and 时间 = \'" & rqsj(2) & "\'"
    Dim drs As List(Of DataRow) = dt.Select(filter, "人数 desc")
    Dim Ispick As new List(of Integer)
    Dim b(drs.Count-1) As Integer
    For i As Integer = 1 To drs.Count
        If i <= drs.Count - IsPick.Count Then
            e.Form.Controls("显示").Text = rqsj(0) & " " & rqsj(1) & " " & rqsj(2) & "(" & i & " " & drs.Count & " " & IsPick.count & ")"
            application.DoEvents
            Functions.Execute("组合排列", drs, b.length, i, b, i, cls, IsPick)
        End If
    Next
    Dim left As Integer = cls(vars("cidx"))("最大安排人数")
    For i As Integer = drs.count - 1 To 0 Step -1
        If Ispick.Contains(i) = False Then
            If left >= drs(i)("人数") Then
                drs(i)("教室") = cls(vars("cidx"))("教室名称")
                left -= drs(i)("人数")
            Else
                vars("cidx") += 1
                If cls.Count > vars("cidx") Then
                    left = cls(vars("cidx"))("最大安排人数")
                    drs(i)("教室") = cls(vars("cidx"))("教室名称")
                    left -= drs(i)("人数")
                Else
                    drs(i)("教室") = "教室不够"
                End If
            End If
        End If
    Next
Next
dt.ResumeRedraw

Tables("国开秩序安排").Sort = "考试地址,短日期,起始时间,人数"
   
    Dim Book2 As New XLS.Book(ProjectPath & "Attachments\\国考秩序安排教室.xls ")
    Dim fl1 As String = ProjectPath & "Reports\\国考秩序安排供安排之用(有建议教室安排).xls"
    Book2.Build() \'生成细节区
    Book2.Save(fl1) \'保存工作簿

msgbox("祝贺您!国考教室安排建议计算完毕,实际安排以您的最终安排为准!")
--  作者：有点蓝
--  发布时间：2016/12/7 9:51:00
--  
正因为看不懂你的代码，也没有时间仔细跟踪分析你的逻辑，所以才让你说说按什么规则来安排教室。麻烦用文字表达一下
--  作者：有点色
--  发布时间：2016/12/7 10:23:00
--  

 无法优化，组合排列本身就是慢的，数据量越大组合的情况越多就越慢。

 

 你排的时候，不要有太多的数据需要组合才行啊。