[已解决]分班技术问题

陈丹青

如何根据所赋的值x,按1至x，再x至1用VBA填充

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-2-25 09:04

1. Sub 分班()
   
2.     Dim mm As Long
   
3.     On Error Resume Next
   
4. 
   
5.     mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
   
6.     If mm <= 0 Then
   
7.         MsgBox "班别数目不符合要求"
   
8.         Exit Sub
   
9.     End If
   
10.    
    
11.     Dim arr, j
    
12.     arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    
13.     For i = 1 To UBound(arr) Step mm * 2
    
14.         For j = 1 To mm
    
15.             arr(i + j - 1, 3) = j
    
16.         Next
    
17.     Next
    
18.     For i = mm + 1 To UBound(arr) Step mm * 2
    
19.         For j = 1 To mm
    
20.             arr(i + j - 1, 3) = mm - j + 1
    
21.         Next
    
22.     Next
    
23.     Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
    
24.     MsgBox "ok"
    
25. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 分班()
   
2.     Dim mm As Long
   
3.     On Error Resume Next
   
4. 
   
5.     mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
   
6.     If mm <= 0 Then
   
7.         MsgBox "班别数目不符合要求"
   
8.         Exit Sub
   
9.     End If
   
10.    
    
11.     Dim arr, j
    
12.     arr = Range("a2:c" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    
13.     For i = 1 To UBound(arr) Step mm * 2
    
14.         For j = 1 To mm
    
15.             arr(i + j - 1, 3) = j
    
16.         Next
    
17.     Next
    
18.     For i = mm + 1 To UBound(arr) Step mm * 2
    
19.         For j = 1 To mm
    
20.             arr(i + j - 1, 3) = mm - j + 1
    
21.         Next
    
22.     Next
    
23.     Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
    
24.     MsgBox "ok"
    
25. End Sub

复制代码

a18332652

说个思路吧，你可以试试：
1、确定单元格A1，然后确定A列的长度（即需要分班的学生人数），
2、取数X，I=1。X是要分几个个班，
3、使参数A=1，A=A+1，I=I+1，判断 A=X？I=分班总人数？，建立循环
4、当A=X时I<分班总人数时，终止循环跳入 A=A-1，I=I+1，判断 A=1?I=分班总人数？
5、当I=分班的总人数时，跳出所有循环结束程序。

baksy

C2单元格公式、下拉。
=IF(MOD(INT((ROW()-2)/8),2)=0,IF(MOD((ROW()-1),8)=1,1,C1+1),IF(MOD((ROW()-1),8)=1,8,C1-1))

hwc2ycy

1. Sub 分班()
   
2.     Dim mm As Long
   
3.     On Error Resume Next
   
4. 
   
5.     mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
   
6.     If mm <= 0 Then
   
7.         MsgBox "班别数目不符合要求"
   
8.         Exit Sub
   
9.     End If
   
10. 
    
11.     Dim arr, j As Long
    
12.     j = Cells(Rows.Count, 1).End(xlUp).Row
    
13.     Range("c2:c" & j).ClearContents
    
14.     arr = Range("a2:c" & j).Value
    
15.     For I = 1 To UBound(arr) Step mm * 2
    
16.         For j = 1 To mm
    
17.             arr(I + j - 1, 3) = j
    
18.             arr(I + j + mm - 1, 3) = mm - j + 1
    
19.         Next
    
20.     Next
    
21.     Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
    
22.     MsgBox "ok"
    
23. End Sub

复制代码

陈丹青

二楼大师实现效果不错，不过，若我想不放C列，放其它列，我试着改了一下，不知怎样修改

陈丹青

Sub 分班()
    Dim mm As Long
    On Error Resume Next

    mm = InputBox("请你输入要分几班:", "班别数目提示息，请输入正整数", "0")
    If mm <= 0 Then
        MsgBox "班别数目不符合要求"
        Exit Sub
    End If

    Dim arr, j As Long
    j = Cells(Rows.Count, 1).End(xlUp).Row '计算A列行数
    Range("c2:c" & j).ClearContents  '清除C列
    arr = Range("a2:c" & j).Value  '选择A至C列的值
    For I = 1 To UBound(arr) Step mm * 2
        For j = 1 To mm
            arr(I + j - 1, 3) = j
            arr(I + j + mm - 1, 3) = mm - j + 1
        Next
    Next
    Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
    MsgBox "ok"
End Sub

后面的比较难,不怎么懂

陈丹青

请问大师,若我要将数据不放C列,放D列,该怎样修改?

陈丹青

搞定,arr = Range("a2:c" & j).Value中的C往后移,3往后

陈丹青

谢谢点评，请多多指教
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