Excel VBA程序开发

jx928867128 Lv.3

关注
image.png

补全任课教师信息.zip   2024-2-27 12:54 上传

19.53 KB, 下载次数: 13

401阅读
11回复 倒序

shiruiqiang Lv.5 2楼

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

jx928867128 楼主 3楼

本帖最后由 jx928867128 于 2024-2-27 13:40 编辑
引用: shiruiqiang 发表于 2024-2-27 13:31
需要先班级、学科及学科教师完成这份字典,否则谁知道那个班级的学科老师是谁?

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

limonet Lv.6 4楼

关键字:抛砖引玉
你自己改一下范围,再加个y循环。
GIF 2024-02-27 14-00-28.gif

补全任课教师信息.zip   2024-2-27 14:01 上传

26.57 KB, 下载次数: 6

shiruiqiang Lv.5 5楼

本帖最后由 shiruiqiang 于 2024-2-27 15:06 编辑

image.jpg


limonet Lv.6 6楼

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 楼主 7楼

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

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

shiruiqiang Lv.5 8楼

image.jpg

补全任课教师信息 2.rar   2024-2-27 15:06 上传

26.58 KB, 下载次数: 14

chxw68 Lv.7 9楼

  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 Lv.7 10楼

参与一下。

补全任课教师信息.rar   2024-2-27 16:02 上传

41.63 KB, 下载次数: 25

加载更多