班级分组--感谢fjlhgs老师的无私付出，-问题已解决，正解在7楼，

yynrzwh

楼上思路的程序实现
假设同班没有同名教师

Sub 分组()
Dim d As Object, lr&, r&, i&, j&, s$, ar
Dim flag As Boolean

Set d = VBA.CreateObject("scripting.dictionary")
With Sheet1
    lr = .Cells(Rows.Count, 1).End(3).Row + 1
    .Range("a2:a" & lr) = ""
    ar = .Range("a1").CurrentRegion
End With

r = 1

Do
    flag = False
    For i = 2 To UBound(ar)
        If Len(ar(i, 1)) = 0 Then
            flag = True
            If Not d.exists(i) Then
                Set d(i) = VBA.CreateObject("scripting.dictionary")
            End If
            
            ar(i, 1) = r
            For j = 3 To UBound(ar, 2)
                s = Trim(ar(i, j))
                If Len(s) > 0 Then
                    If isrep(s, d) Then
                        ar(i, 1) = ""
                        d.Remove i
                        Exit For
                    Else
                        d(i)(s) = ""
                    End If
                End If
            Next
        End If
    Next
    r = r + 1
    d.RemoveAll
Loop While flag

Sheet1.Range("a1").CurrentRegion = ar

Set d = Nothing
End Sub
Private Function isrep(teacher, d)
Dim flag As Boolean, k

flag = False
For Each k In d.keys
    If d(k).exists(teacher) Then
        flag = True
        Exit For
    End If
Next

isrep = flag
End Function


Sheet1.zip (30.54 KB, 下载次数: 12)

2024-8-3 10:05 上传

点击文件名下载附件

jx928867128

yynrzwh 发表于 2024-8-3 10:06
楼上思路的程序实现
假设同班没有同名教师

感谢老师的帮忙，再次谢谢

jx928867128

yynrzwh 发表于 2024-8-3 10:06
楼上思路的程序实现
假设同班没有同名教师

https://club.excelhome.net/forum ... ;page=2#pid11533318老师您写的这个小程序方便发出来吗，我工作中有需要

yynrzwh

jx928867128 发表于 2024-8-3 15:06
https://club.excelhome.net/forum.php?mod=viewthread&tid=1695800&page=2#pid11533318老师您写的这个小 ...

longwin 坛友在https://club.excelhome.net/thread-1698435-4-1.html
就是模拟人工调整的程序，我写的总体思路也是差不多的，我就不献丑了。

sdytsxd991122

参与一下

jx928867128

sdytsxd991122 发表于 2024-8-4 11:55
参与一下

感谢大神的参与，再次谢谢，方便发个附件吗

sdytsxd991122

jx928867128 发表于 2024-8-4 12:46
感谢大神的参与，再次谢谢，方便发个附件吗

...................

kyxfyzg

Sub test()
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
    For j = 1 To UBound(arr, 2)
        arr(i, j) = WorksheetFunction.Trim(arr(i, j))
    Next j
Next i
For i = 2 To UBound(arr)
    If arr(i, 1) = "" Then
        n = n + 1
        arr(i, 1) = n
        brr = WorksheetFunction.Index(arr, i, 0)
        For m = i + 1 To UBound(arr)
            If arr(m, 1) = "" Then
            crr = WorksheetFunction.Index(arr, m, 0)
                For j = 1 To UBound(brr)
                    If brr(j) <> "" Then
                        frr = Filter(crr, brr(j))
                        If UBound(frr) >= 0 Then arr(m, 1) = n: Exit For
                    End If
                Next j
            End If
        Next m
    End If
Next i
drr = WorksheetFunction.Index(arr, 0, 1)
Range("a1").Resize(UBound(drr), 1) = drr
End Sub