根据“教师课程分担”与“部颁课时”得到承担课程课时任务一览表

偶然古月照江北 · 发表于 2018-9-1 12:10

目标：根据“教师课程分担”与“部颁课时”得到承担课程课时任务一览表。公式或VBA均可，关键是速度……最近在工作中遇到这个难题，希望得到各位大神的帮助，成分感激啊！！！

chxw68 · 发表于 2018-9-1 12:46

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("部颁课时")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(2, .Columns.Count).End(xlToLeft).Column
arr = .Range("a2").Resize(r - 1, c)
For i = 2 To UBound(arr)
bj = InStr("一二三四五六七八九", arr(i, 1))
Set d1(bj) = CreateObject("scripting.dictionary")
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
d1(bj)(arr(1, j)) = arr(i, j)
End If
Next
Next
End With
With Worksheets("教师课程分担")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For i = 2 To UBound(arr)
bj = Val(Left(arr(i, 1), 1))
If d1.exists(bj) Then
For j = 2 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
If d1(bj).exists(arr(1, j)) Then
If Not d.exists(arr(i, j)) Then
ReDim brr(1 To 2)
brr(1) = arr(i, 1) & arr(1, j) & d1(bj)(arr(1, j))
Else
brr = d(arr(i, j))
brr(1) = brr(1) & "；" & arr(1, j) & d1(bj)(arr(1, j))
End If
brr(2) = brr(2) + d1(bj)(arr(1, j))
d(arr(i, j)) = brr
End If
End If
Next
End If
Next
With Worksheets("课时分担一览表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("c2:d" & r).ClearContents
arr = .Range("a2:d" & r)
For i = 1 To UBound(arr)
If d.exists(arr(i, 2)) Then
brr = d(arr(i, 2))
arr(i, 3) = brr(1)
arr(i, 4) = brr(2)
End If
Next
.Range("a2:d" & r) = arr
End With
End Sub

复制代码

chxw68 · 发表于 2018-9-1 12:47

详见附件。

excelvlookup · 发表于 2018-9-1 13:25

Sub aa()
Set d = CreateObject("scripting.dictionary")
With Sheets("教师课程分担")
rw1 = .Cells(Rows.Count, 1).End(3).Row
js = .Range("a1:q" & rw1)
End With
With Sheets("部颁课时")
rw2 = .Cells(Rows.Count, 1).End(3).Row
bb = .Range("b2:q" & rw2)
End With
ReDim ar(1 To UBound(js) * UBound(js, 2), 1 To 4)
For i = 1 To UBound(bb, 2)
ky = bb(1, i)
For j = 2 To UBound(bb)
      d(ky & j - 1) = bb(j, i)
Next
Next
For i = 2 To UBound(js)
lj = Mid(js(i, 1), 1, 1)
For j = 2 To UBound(js, 2)
      kc = js(1, j)
      If js(i, j) <> "" Then
         r = d(js(i, j))
         If r = "" Then
            s = s + 1
            d(js(i, j)) = s
            ar(s, 1) = s: ar(s, 2) = js(i, j)
            ar(s, 3) = js(i, 1) & kc & d(kc & lj)
            ar(s, 4) = d(kc & lj)
         Else
            ar(r, 3) = ar(r, 3) & ";" & js(i, 1) & kc & d(kc & lj)
            ar(r, 4) = ar(r, 4) + d(kc & lj)
         End If
      End If
Next
Next
Sheet4.Range("a2").Resize(s, 4) = ar
End Sub
加了一个表做测试

excelvlookup · 发表于 2018-9-1 13:26

再送上附件

偶然古月照江北 · 发表于 2018-9-2 16:40

万分感谢chxw68和excelvlookup两位老师的帮助！！！

偶然古月照江北 · 发表于 2018-9-2 16:46

还想请教excelvlookup老师，在课程分担表中，我不想改变教师姓名的顺序，该怎么做？

excelvlookup · 发表于 2018-9-2 17:28

本帖最后由 excelvlookup 于 2018-9-2 17:30 编辑

偶然古月照江北发表于 2018-9-2 16:46
还想请教excelvlookup老师，在课程分担表中，我不想改变教师姓名的顺序，该怎么做？

把这个Sheet4.Range("e2").Resize(s, 4) = ar改成这个Sheet4.Range("e2").Resize(UBound(fd), 4) = fd。并在其前面加上如下代码：
With Sheets("课时分担一览表 ")
rw3 = .Cells(Rows.Count, 1).End(3).Row
fd = .Range("a2:d" & rw3)
End With
for i=1 to s
for j=3 to ubound(fd,2)
fd(i,j)=ar(d(fd(i,2)),j)
next
next

偶然古月照江北 · 发表于 2018-9-2 20:22

excelvlookup 发表于 2018-9-2 17:28
把这个Sheet4.Range("e2").Resize(s, 4) = ar改成这个Sheet4.Range("e2").Resize(UBound(fd), 4) = fd。 ...

谢谢，高手！请问：如果课时分担一览表中的序号和姓名是链接过来的，我想保留序号和姓名链接怎么办？

excelvlookup · 发表于 2018-9-2 21:00

是想要一个超连接吗？
在教师表中增加代码如下：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 1 And Target.Column > 1 And Target.Value <> "" Then
With Sheets("课时分担一览表 ")
      rw = .Cells(Rows.Count, 1).End(3).Row
      Set xm = .Range("b2:b" & rw).Find(Target.Value)
      If Not xm Is Nothing Then
      hh = xm.Row
      .Select
      .Range("a" & hh).Select
      End If
End With
End If
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 根据“教师课程分担”与“部颁课时”得到承担课程课时任务一览表