当q3=相应年级，就依次显示相关信息

杜立城

请高手写一段代码，当q3=相应年级，就依次显示基础表中的四列(K:n)对应年级教师信息到本表的abc三列

1055751654

1. Option Explicit
   
2. 
   
3. Sub 玩玩()
   
4. Dim rng As Range, arr()
   
5. Dim n&, q%, ww, w
   
6. With Sheets("基础表")
   
7. Set rng = .Range("i:i").Find(Worksheets("计算").Range("q2"), , , 1)
   
8.     If Not rng Is Nothing Then
   
9.     ww = rng.Address
   
10.     End If
    
11.     For q = 2 To 5
    
12.         n = n + 1
    
13.         ReDim Preserve arr(1 To 3, 1 To n)
    
14.         arr(1, n) = rng.Offset(, q)
    
15.         arr(2, n) = rng.Offset(, 1)
    
16.         arr(3, n) = .Cells(2, rng.Offset(, q).Column)
    
17.     Next
    
18. Do
    
19. Set rng = Sheets("基础表").Range("i:i").FindNext(rng)
    
20.     w = rng.Address
    
21.     For q = 2 To 5
    
22.         n = n + 1
    
23.         ReDim Preserve arr(1 To 3, 1 To n)
    
24.         If ww = w Then Exit Do
    
25.         arr(1, n) = rng.Offset(, q)
    
26.         arr(2, n) = rng.Offset(, 1)
    
27.         arr(3, n) = .Cells(2, rng.Offset(, q).Column)
    
28.     Next
    
29. Loop
    
30. 
    
31. Sheets("计算").Range("a4").Resize(UBound(arr, 2), 3) = Application.Transpose(arr)
    
32. End With
    
33. End Sub
    

复制代码

1016373263

用字典：
Sub 教师信息()
Dim sht As Worksheet, sht1 As Worksheet, d, arr
Set d = CreateObject("scripting.dictionary")
Set sht = Worksheets("基础表"): Set sht1 = Worksheets("计算")
arr = sht.Range("i2:n" & sht.Cells(Rows.Count, 9).End(xlUp).Row)
For j = 3 To UBound(arr, 2)
    For i = 2 To UBound(arr)
        If arr(i, 1) = sht1.Range("q2").Value Then
         If arr(i, j) <> "" Then
          d(arr(i, j) & "|" & arr(i, 2) & "|" & arr(1, j)) = arr(i, 1)
          End If
        End If
    Next
Next
sht1.Cells(4, 1).Resize(1, 3) = ""
For i = 0 To d.Count - 1
    sht1.Cells(i + 4, 1).Resize(1, 3) = Split(d.keys()(i), "|")
Next
End Sub