[已解决]求助：提取（难）

夹竹桃

老师们：
    中午好！首先感谢论坛里热心助人的老师们，感谢你们的无私和热诚！
    能不能根据"设置"中的情况，用VBA变换成“SHEET2”中的格式？
    恳请老师们帮忙写一段VBA。谢谢！

最佳答案

月排行榜 / 总排行榜

FF7

2011-8-13 15:13

晕，公司里面好像出麻烦了！！！
闪了！！

跳转到最佳答案楼层

fjmxwrs

留脚印跟踪学习

夹竹桃

如果VBA 不能做  函数也行啊   老师们

FF7

晕，公司里面好像出麻烦了！！！
闪了！！

zjdh

我也来一个：

1. Sub test()
   
2.     Dim arr(), D, I%, J%, N$, K
   
3.     Sheets("sheet3").Range("A:D").ClearContents
   
4.     Set D = CreateObject("scripting.dictionary")
   
5.     For I = 3 To 11
   
6.         For J = 20 To Cells(65536, 1).End(3).Row
   
7.             If Cells(J, 1).Value <> "" Then
   
8.                 N = Cells(J, 1) & "|" & Cells(19, I) & "|" & Cells(J, I)
   
9.                 If Not D.exists(N) Then
   
10.                     D.Add N, Cells(J, 2)
    
11.                 Else
    
12.                     D(N) = D(N) & "," & Cells(J, 2)
    
13.                 End If
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     K = D.keys
    
18.     ReDim arr(1 To D.Count, 1 To 4)
    
19.     For I = 1 To D.Count
    
20.     arr(I, 1) = Split(K(I - 1), "|")(0)
    
21.     arr(I, 2) = D(K(I - 1))
    
22.     arr(I, 3) = Split(K(I - 1), "|")(1)
    
23.     arr(I, 4) = Split(K(I - 1), "|")(2)
    
24.     Next
    
25.     Sheets("sheet3").Cells(1, 1).Resize(1, 4) = Array("年级", "班别", "科目", "代课老师")
    
26.     Sheets("sheet3").Cells(2, 1).Resize(D.Count, 4) = arr
    
27. End Sub

复制代码

夹竹桃

zjdh 老师：
十分感谢！

夹竹桃

zjdh 老师：
再次感谢！你写的这段VBA很合我意！可是，你知道我是一句英语不懂！！你能在百忙中给我修改一下吗，让粘贴在SHEET3中的数据从A4开始吗。

smlok

留脚印跟踪学习

zjdh

Sub test()
    Dim arr(), D, I%, J%, N$, K
    Sheets("sheet3").Range("A:D").ClearContents
    Set D = CreateObject("scripting.dictionary")
    For I = 3 To 11
        For J = 20 To Cells(65536, 1).End(3).Row
            If Cells(J, 1).Value <> "" Then
                N = Cells(J, 1) & "|" & Cells(19, I) & "|" & Cells(J, I)
                If Not D.exists(N) Then
                    D.Add N, Cells(J, 2)
                Else
                    D(N) = D(N) & "," & Cells(J, 2)
    End If: End If: Next: Next
    K = D.keys
    ReDim arr(1 To D.Count, 1 To 4)
    For I = 1 To D.Count
    arr(I, 1) = Split(K(I - 1), "|")(0)
    arr(I, 2) = D(K(I - 1))
    arr(I, 3) = Split(K(I - 1), "|")(1)
    arr(I, 4) = Split(K(I - 1), "|")(2)
    Next
    Sheets("sheet3").Cells(4, 1).Resize(1, 4) = Array("年级", "班别", "科目", "代课老师")
    Sheets("sheet3").Cells(5, 1).Resize(D.Count, 4) = arr
End Sub

夹竹桃

谢谢！zjdh 老师