补全任课老师

jx928867128

补全任课教师信息.zip (19.53 KB, 下载次数: 14)

2024-2-27 12:54 上传

点击文件名下载附件

shiruiqiang

需要先班级、学科及学科教师完成这份字典，否则谁知道那个班级的学科老师是谁？

jx928867128

shiruiqiang 发表于 2024-2-27 13:31
需要先班级、学科及学科教师完成这份字典，否则谁知道那个班级的学科老师是谁？

谢谢您的关注，同一行里面的数据可以确定这个班级各个科目的任课老师

limonet

关键字：抛砖引玉
你自己改一下范围，再加个y循环。

shiruiqiang

limonet

Sub limonet()
    Dim i%, j%, Arr As Variant, Brr As Variant
    Arr = Range("C5:P5")
    For i = 1 To UBound(Arr, 2)
        If Len(Arr(1, i)) = 3 And Not Arr(1, i) Like "自习*" Then
            Brr = Filter(Application.Transpose(Application.Transpose(Arr)), Arr(1, i))
            For j = 0 To UBound(Brr)
                If Len(Brr(j)) > 3 Then Arr(1, i) = Brr(j)
            Next j
        End If
    Next i
    Range("C5:P5") = Arr
End Sub

jx928867128

limonet 发表于 2024-2-27 14:01
关键字：抛砖引玉
你自己改一下范围，再加个y循环。

谢谢好心人的帮忙，范围修改我会，但加个y环不会啊

shiruiqiang

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("汇总")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         c = .Cells(4, .Columns.Count).End(xlToLeft).Column
   
9.         arr = .Range("a5").Resize(r - 4, c)
   
10.         For i = 1 To UBound(arr)
    
11.             d.RemoveAll
    
12.             For j = 2 To UBound(arr, 2)
    
13.                 If Len(arr(i, j)) <> 0 Then
    
14.                     xm = Split(arr(i, j), vbLf)
    
15.                     If xm(1) <> "" Then
    
16.                         xm1 = Split(xm(0), "/")
    
17.                         xm2 = Split(xm(1), "/")
    
18.                         If UBound(xm1) = UBound(xm2) Then
    
19.                             For k = 0 To UBound(xm1)
    
20.                                 d(Left(xm1(k), 1)) = xm2(k)
    
21.                             Next
    
22.                         End If
    
23.                     End If
    
24.                 End If
    
25.             Next
    
26.             For j = 2 To UBound(arr, 2)
    
27.                 ss = Empty
    
28.                 If Len(arr(i, j)) <> 0 Then
    
29.                     xm = Split(arr(i, j), vbLf)
    
30.                     If xm(1) = "" Then
    
31.                         xm1 = Split(xm(0), "/")
    
32.                         For k = 0 To UBound(xm1)
    
33.                             If d.exists(Left(xm1(k), 1)) Then
    
34.                                 ss = ss & "/" & d(Left(xm1(k), 1))
    
35.                             End If
    
36.                         Next
    
37.                         If ss <> mepty Then
    
38.                             arr(i, j) = xm(0) & vbLf & Mid(ss, 2)
    
39.                         End If
    
40.                     End If
    
41.                 End If
    
42.             Next
    
43.             
    
44.         Next
    
45.         .Range("a5").Resize(r - 4, c) = arr
    
46.     End With
    
47. End Sub
    

复制代码

chxw68

参与一下。