[已解决]分班技术问题

陈丹青

分开排合理一点，我暂时还不知，要问问里面的大师

billyzhang0609

进来学习

dyzx

请老师出手解决此问题，多谢。

dyzx

请老师出手解决此问题，多谢。

陈丹青

搞定
    Range("i2").Select
    Range("A1:j" & [B65536].End(3).Row).Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:= _
        Range("C2"), Order2:=xlDescending, Header:=xlGuess
        
    Range("D2:D" & [D65536].End(3).Row).ClearContents         'M列到有数据的行内容清除
     Range("D1") = "班"
    Dim mm As Long
    On Error Resume Next
    mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
    If mm <= 0 Then
        MsgBox "班别数目不符合要求"
        Exit Sub
    End If

    Dim arr, j, s, a As Long
    j = Range("B:B").Find("女", , , , , xlPrevious).Row ' Cells(Rows.Count, 2).End(xlUp).Row '第二列有数据的行
    arr = Range("a2:D" & j).Value           '选择A2到K最后
    For i = 1 To UBound(arr) Step mm * 2
        For j = 1 To mm
            arr(i + j - 1, 4) = j                 '写到4列
            arr(i + j + mm - 1, 4) = mm - j + 1    '写到4列
            
        Next
    Next
    Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
   
     a = Application.WorksheetFunction.CountIf(Range("B1:B65536"), "女") + 1
    j = Range("B:B").Find("男", , , , , xlPrevious).Row ' Cells(Rows.Count, 2).End(xlUp).Row '第二列有数据的行
    arr = Range("a2:D" & j).Value           '选择A2到K最后
    For i = a To UBound(arr) Step mm * 2
        For j = 1 To mm
            arr(i + j + mm - 1, 4) = j               '写到4列
            arr(i + j - 1, 4) = mm - j + 1    '写到4列
            
        Next
    Next
    Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr

dyzx

陈丹青 发表于 2014-4-28 17:12
搞定
    Range("i2").Select
    Range("A1:j" & .End(3).Row).Sort Key1:=Range("B2"), Order1:=xlDesc ...

陈丹青老师：非常多谢你在百忙之中抽时间为我解决一大难题，多谢、多谢。

陈丹青

Sub 定班() '先女后男，女先升后降，男先降后升，平均分较均匀
    Range("i2").Select
    Range("A1:j" & [B65536].End(3).Row).Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:= _
        Range("C2"), Order2:=xlDescending, Header:=xlGuess
        
     Range("D1") = "班"
    Dim mm As Long
    On Error Resume Next
    mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
    If mm <= 0 Then
        MsgBox "班别数目不符合要求"
        Exit Sub
    End If

    Dim arr, j, s, a As Long
    j = Range("B:B").Find("女", , , , , xlPrevious).Row ' Cells(Rows.Count, 2).End(xlUp).Row '第二列有数据的行
    Range("D2:D" & [d65536].End(3).Row).ClearContents         'M列到有数据的行内容清除
    arr = Range("a2:D" & j).Value           '选择A2到K最后
    For i = 1 To UBound(arr) Step mm * 2
        For j = 1 To mm
            arr(i + j - 1, 4) = j                 '写到4列
            arr(i + j + mm - 1, 4) = mm - j + 1    '写到4列
            
        Next
    Next
    Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
   
     a = Application.WorksheetFunction.CountIf(Range("B1:B65536"), "女") + 1
    j = Range("B:B").Find("男", , , , , xlPrevious).Row ' Cells(Rows.Count, 2).End(xlUp).Row '第二列有数据的行
    arr = Range("a2:D" & j).Value           '选择A2到K最后
    For i = a To UBound(arr) Step mm * 2
        For j = 1 To mm
            arr(i + j + mm - 1, 4) = j               '写到4列
            arr(i + j - 1, 4) = mm - j + 1    '写到4列
            
        Next
    Next
    Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr

End Sub

dyzx

陈丹青 发表于 2014-4-29 10:23
Sub 定班() '先女后男，女先升后降，男先降后升，平均分较均匀
    Range("i2").Select
    Range("A1:j" ...

多谢陈老师