请教：有没有办法可以按照本班性别人数均衡分组？

一把小刀闯天下

wtqzhjb 发表于 2019-2-12 09:53
师兄，能不能这样改一下，直接把各班男生女生的组序号，填写在指定的列即可？（位置变了）谢谢你，麻烦你 ...

'楼主开始变形了，，，

Option Explicit

Sub test()
  Dim arr, i, j, k, kk, a, b, m, n, p, cnt
  arr = [a1].CurrentRegion.Offset(1)
  ReDim brr(1 To UBound(arr, 1), 1 To 1)
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) <> arr(j + 1, 1) Then
        For a = i To j
          For b = a To j
            If arr(b, 1) <> arr(b + 1, 1) Or arr(b, 5) <> arr(b + 1, 5) Then
              If b - a + 1 >= 8 Then
                n = (b - a + 1) Mod 8: p = 8
                For k = 9 To 10
                  If (b - a + 1) Mod k < n Then p = k: n = (b - a + 1) Mod k
                Next
                If n > 4 Then
                  For k = 6 To 7
                    If (b - a + 1) Mod k < n Then p = k: n = (b - a + 1) Mod k
                  Next
                End If
              Else
                n = 0: p = (b - a + 1)
              End If
              For k = a To b - n Step p
                cnt = cnt + 1
                For kk = k To k + p - 1: m = m + 1: brr(m, 1) = cnt & "组": Next
              Next
              If n > 0 Then
                For k = b - n + 1 To b
                  m = m + 1: brr(m, 1) = cnt & "组"
                Next
              End If
              a = b: Exit For
            End If
        Next b, a
        i = j: cnt = 0: Exit For
      End If
  Next j, i
  [f2].Resize(UBound(brr, 1)) = brr
End Sub

wtqzhjb

一把小刀闯天下 发表于 2019-2-12 11:19
'楼主开始变形了，，，

Option Explicit

谢谢师兄的耐心解答，谢谢，新年快乐哈

wtqzhjb

一把小刀闯天下 发表于 2019-2-12 11:19
'楼主开始变形了，，，

Option Explicit

非常厉害，完全好用，谢谢啦

yjh_27

wtqzhjb 发表于 2019-2-12 10:44
师兄，这样你看好不好处理：如果余数不好处理，是否可以直接：7人一组，最多不超过13人，该性别总人数不 ...

参见附件。

wtqzhjb

yjh_27 发表于 2019-2-12 12:32
参见附件。

谢谢，非常好用