[已解决]请VBA高手，帮帮我，怎样才能达成这样的效果。

excel010

请VBA的高手们，帮我达成这种效果。

如图：



ch]246203[/attach]
自动复制粘贴.rar (7.29 KB, 下载次数: 24)

2012-8-23 15:36 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zm0115

2012-8-23 16:10

1. Sub test()
   
2. Dim d As Object
   
3. Dim x&
   
4. Dim arr, brr
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. 
   
7. For x = 5 To Cells(Rows.Count, "k").End(3).Row
   
8.     d(Cells(x, "k").Value) = Cells(x, "r").Value
   
9. Next
   
10. For x = 5 To Cells(Rows.Count, "ah").End(3).Row
    
11.     d(Cells(x, "ah").Value) = Cells(x, "ao").Value
    
12. Next
    
13. 
    
14. arr = d.keys
    
15. brr = d.items
    
16. 
    
17. For x = 0 To UBound(arr)
    
18.     Cells(5 + x, "k") = arr(x)
    
19.     Cells(5 + x, "r") = brr(x)
    
20. Next
    
21. Set d = Nothing
    
22. End Sub
    

复制代码

跳转到最佳答案楼层

zm0115

1. Sub test()
   
2. Dim d As Object
   
3. Dim x&
   
4. Dim arr, brr
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. 
   
7. For x = 5 To Cells(Rows.Count, "k").End(3).Row
   
8.     d(Cells(x, "k").Value) = Cells(x, "r").Value
   
9. Next
   
10. For x = 5 To Cells(Rows.Count, "ah").End(3).Row
    
11.     d(Cells(x, "ah").Value) = Cells(x, "ao").Value
    
12. Next
    
13. 
    
14. arr = d.keys
    
15. brr = d.items
    
16. 
    
17. For x = 0 To UBound(arr)
    
18.     Cells(5 + x, "k") = arr(x)
    
19.     Cells(5 + x, "r") = brr(x)
    
20. Next
    
21. Set d = Nothing
    
22. End Sub
    

复制代码

excel010

zm0115 发表于 2012-8-23 16:10

老师·················

zm0115

excel010 发表于 2012-8-23 18:16
老师·················

1. Sub test()
   
2. Dim d As Object
   
3. Dim x&, y&
   
4. Dim arr, brr
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. 
   
7. For x = 5 To Cells(Rows.Count, "k").End(3).Row
   
8.     d(Cells(x, "k").Value) = Cells(x, "l").Resize(1, 7)
   
9.    
   
10. Next
    
11. For x = 5 To Cells(Rows.Count, "ah").End(3).Row
    
12.     d(Cells(x, "ah").Value) = Cells(x, "ai").Resize(1, 7)
    
13. Next
    
14. 
    
15. arr = d.keys
    
16. brr = d.items
    
17. 
    
18. For x = 0 To UBound(arr)
    
19.     Cells(5 + x, "k") = arr(x)
    
20.     For y = 1 To 7
    
21.         Cells(5 + x, "k").Offset(0, y) = brr(x)(1, y)
    
22.     Next
    
23. Next
    
24. Set d = Nothing
    
25. 
    
26. End Sub
    
27. 
    

复制代码

excel010

zm0115 发表于 2012-8-23 22:20

xx谢谢老师··············！！！