[已解决]排课

xiaoni

排课.zip (6.63 KB, 下载次数: 17)

2016-3-27 18:27 上传

点击文件名下载附件 问题在附件中，请有空的老师帮忙，谢谢

最佳答案

月排行榜 / 总排行榜

爱疯

2016-3-27 18:55

排课2.rar (13.1 KB, 下载次数: 32)

2016-3-27 18:54 上传

点击文件名下载附件

按步就搬想的




Sub test()
    Dim A, d, k, t
    Dim i, j, x
    A = Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")

    For i = 2 To UBound(A)
        x = A(i, 1) & "," & A(i, 2)
        d(x) = d(x) + 1
    Next i
    k = d.keys: t = d.items: x = 0
    ReDim A(1 To (UBound(k) + 1) * 8, 1 To 2)

    For i = 0 To UBound(k)
        For j = 1 To 8
            x = x + 1
            A(x, 1) = IIf(j > t(i), "", Split(k(i), ",")(0))
            A(x, 2) = IIf(j > t(i), "", Split(k(i), ",")(1))
        Next j
    Next i

    With Sheets(2)
        .Select
        .Range("a:b") = ""
        .[a1].Resize(UBound(A), UBound(A, 2)) = A
    End With
End Sub

跳转到最佳答案楼层

爱疯

排课2.rar (13.1 KB, 下载次数: 32)

2016-3-27 18:54 上传

点击文件名下载附件

按步就搬想的




Sub test()
    Dim A, d, k, t
    Dim i, j, x
    A = Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")

    For i = 2 To UBound(A)
        x = A(i, 1) & "," & A(i, 2)
        d(x) = d(x) + 1
    Next i
    k = d.keys: t = d.items: x = 0
    ReDim A(1 To (UBound(k) + 1) * 8, 1 To 2)

    For i = 0 To UBound(k)
        For j = 1 To 8
            x = x + 1
            A(x, 1) = IIf(j > t(i), "", Split(k(i), ",")(0))
            A(x, 2) = IIf(j > t(i), "", Split(k(i), ",")(1))
        Next j
    Next i

    With Sheets(2)
        .Select
        .Range("a:b") = ""
        .[a1].Resize(UBound(A), UBound(A, 2)) = A
    End With
End Sub

lichuanboy44

练手，也试了一下。
楼上数组内操作，速度快，我的插入行时在工作表操作较多，如果数据量大，速度较慢。

爱疯

Sub test2()
    Dim A, B(1 To 10000, 1 To 2), i, s, n
    Sheets(1).Select
    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, _
                      Key2:=Range("B1"), Order2:=xlAscending, Header:=xlYes
    A = Range("a1:b" & Range("a65536").End(3).Row + 1)
    n = 8

    For i = 2 To UBound(A) - 1
        s = s + 1
        B(s, 1) = A(i, 1)
        B(s, 2) = A(i, 2)

        '当与下次不一样时，就修改s
        If A(i, 1) <> A(i + 1, 1) Or A(i, 2) <> A(i + 1, 2) Then
            s = IIf(s Mod n = 0, s, (s \ n + 1) * n)
        End If
    Next i

    With Sheets(2)
        .Select
        .Range("a:b") = ""
        .[a1].Resize(s, 2) = B
    End With
End Sub

排课3.rar (15.15 KB, 下载次数: 21)

2016-3-28 09:33 上传

点击文件名下载附件

xiaoni

爱疯 发表于 2016-3-27 18:55
按步就搬想的

老师能用一个按钮增加删除行吗？

爱疯

d(x)+1，是字典项的值，更具体的说是x的出现次数

爱疯

用一个按钮，增加删除行，不懂是要做什么

xiaoni

爱疯 发表于 2016-3-28 21:37
用一个按钮，增加删除行，不懂是要做什么

就是当有空行时就删除空行，没有空行时就增加行

byzd20011

谢谢分享