怎样用VBA核对教师上课冲突问题

fgq5910

需求：
怎样用VBA核对教师上课冲突问题
教师同一时间只能上一个班的课，合班除外，
五个班以上（含五个班）算合班 ，上课不冲突，
否则算上课冲突
如：第十二行，刘七排了四个班的课，算冲突
第六行领导2上大课，不冲突。但周八重复，冲突了
第四行、第八行、第九行和第十六行，
同一教师排了五个以上的班，不算冲突
七个班都没课，为空
谢谢！

liulang0808

Sub TEST()
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For j = 3 To UBound(arr)
        d.RemoveAll
        For i = 4 To 10
            If Len(arr(j, i)) > 0 Then
                If Not d.exists(arr(j, i)) Then
                    Set d(arr(j, i)) = Cells(j, i)
                Else
                    Set d(arr(j, i)) = Union(d(arr(j, i)), Cells(j, i))
                End If
            End If
        Next i
        If d.Count = 0 Then
            arr(j, 12) = ""
        Else
            str1 = ""
            arr(j, 12) = "无冲突"
            arr(j, 11) = ""
            For Each k In d.keys
                If d(k).Cells.Count >= 5 Then
                    str1 = str1 & "," & k & "上合班大课"
                Else
                    If d(k).Cells.Count > 1 Then
                        d(k).Interior.ColorIndex = 3
                        arr(j, 12) = "冲突"
                    End If
                End If
            Next k
            If Len(str1) > 0 Then arr(j, 11) = Mid(str1, 2) & ",不冲突"
        End If
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

供参考

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2023.12.24
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 3).End(3).Row
   
5.     arr = Range("c3:l" & r)
   
6.     For i = 1 To UBound(arr)
   
7.         n = 0: m = 0: d.RemoveAll
   
8.         For j = 2 To UBound(arr, 2) - 2
   
9.             If Trim(arr(i, j)) <> Empty Then
   
10.                 m = m + 1
    
11.                 s = Trim(arr(i, j))
    
12.                 d(s) = d(s) + 1
    
13.             End If
    
14.         Next
    
15.         ft = 0
    
16.         For Each k In d.keys
    
17.             If d(k) > 1 And d(k) < 5 Then ft = 1
    
18.             If ft = 1 And d(k) > 1 And d(k) < 5 Then ft = 2
    
19.         Next
    
20.         If ft <= 2 Then arr(i, 10) = "冲突"
    
21.         If ft = 0 Then arr(i, 10) = "不冲突"
    
22.         If m = 0 Then arr(i, 10) = ""
    
23.     Next
    
24.     Range("c3:l" & r) = arr
    
25. End Sub
    

复制代码

ykcbf1100

。。。。。。

1. 
   

复制代码

ykcbf1100

附件供参考。。。

cyq4896

参与一下..

fgq5910

感谢各位高手的帮助！
求助成功