根据科目号依次取值。

lwcx8899

123.rar (2.04 KB, 下载次数: 10)

2014-4-23 14:55 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim d As Object
   
3.   Dim d1 As Object
   
4.   Dim r%, i%
   
5.   Dim arr, brr()
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 6).End(xlUp).Row
    
11.     arr = .Range("f3:g" & r)
    
12.   End With
    
13.   For i = 1 To UBound(arr)
    
14.     If Not d.Exists(arr(i, 1)) Then
    
15.       m = 1
    
16.     Else
    
17.       brr = d(arr(i, 1))
    
18.       m = UBound(brr) + 1
    
19.     End If
    
20.     ReDim Preserve brr(1 To m)
    
21.     brr(m) = arr(i, 2)
    
22.     d(arr(i, 1)) = brr
    
23.   Next
    
24.   tt = d.Items
    
25.   
    
26.   With Worksheets("sheet1")
    
27.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
28.     arr = .Range("a3:c" & r)
    
29.     For i = 1 To UBound(arr)
    
30.       d1(arr(i, 2)) = d1(arr(i, 2)) + 1
    
31.       If d.Exists(arr(i, 2)) Then
    
32.         brr = d(arr(i, 2))
    
33.         If d1(arr(i, 2)) <= UBound(brr) Then
    
34.           arr(i, 3) = brr(d1(arr(i, 2)))
    
35.         End If
    
36.       End If
    
37.     Next
    
38.     .Range("a3").Resize(UBound(arr), 3) = arr
    
39.   End With
    
40. End Sub
    

复制代码

chxw68

字典+数组的。

chxw68

又做了个字典嵌套的。

1. Sub test2()
   
2.   Dim d As Object
   
3.   Dim d1 As Object
   
4.   Dim r%, i%
   
5.   Dim arr, brr()
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Set d1 = CreateObject("scripting.dictionary")
   
8.   
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 6).End(xlUp).Row
    
11.     arr = .Range("f3:g" & r)
    
12.   End With
    
13.   For i = 1 To UBound(arr)
    
14.     If Not d.Exists(arr(i, 1)) Then
    
15.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
16.     End If
    
17.     n = d(arr(i, 1)).Count + 1
    
18.     d(arr(i, 1))(n) = arr(i, 2)
    
19.   Next
    
20.    
    
21.   With Worksheets("sheet1")
    
22.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
23.     arr = .Range("a3:c" & r)
    
24.     For i = 1 To UBound(arr)
    
25.       If d.Exists(arr(i, 2)) Then
    
26.         d1(arr(i, 2)) = d1(arr(i, 2)) + 1
    
27.         If d(arr(i, 2)).Exists(d1(arr(i, 2))) Then
    
28.           arr(i, 3) = d(arr(i, 2))(d1(arr(i, 2)))
    
29.         End If
    
30.       End If
    
31.     Next
    
32.     .Range("a3").Resize(UBound(arr), 3) = arr
    
33.   End With
    
34. End Sub

复制代码

chxw68

参见附件。

lwcx8899

chxw68 发表于 2014-4-23 15:15
参见附件。

谢谢！如果把列改成行后，代码该如何修改？ 按科目提取金额.rar (10.49 KB, 下载次数: 8)

2014-4-23 16:42 上传

点击文件名下载附件

bluexuemei

1. Sub t()
   
2. '须安装ACTIVERUBY.才能运行
   
3. '下载地址  http://www.artonx.org/data/asr/ActiveRuby.msi
   
4. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
5. ojs.eval ("def aa(aa) $aa=aa end")
   
6. y = ojs.Run("aa", Range("f3", [g3].End(4)).Value)
   
7. y = ojs.eval("a=$aa.group_by{|x|x[0]}.to_a.map{|x|x[1]}.map{|x|x.each_with_index{|v,i|v.unshift(i+1)}}.flatten(1).sort_by{|x|x[1]}")
   
8. [a3].Resize(UBound(y) + 1, 3) = y
   
9. Stop
   
10. End Sub

复制代码

bluexuemei

第二个问题

1. Sub t()
   
2. '须安装ACTIVERUBY.才能运行
   
3. '下载地址  http://www.artonx.org/data/asr/ActiveRuby.msi
   
4. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
5. ojs.eval ("def aa(aa) $aa=aa end")
   
6. y = ojs.Run("aa", Range("f3", [g3].End(4)).Value)
   
7. y = ojs.eval("a=[];a=$aa.sort_by{|x|x[0]}.map{|x|x[1]}.each_slice(3).to_a;a.transpose")
   
8. [b3].Resize(UBound(y) + 1, 3) = y
   
9. Stop
   
10. End Sub

复制代码

chxw68

lwcx8899 发表于 2014-4-23 16:43
谢谢！如果把列改成行后，代码该如何修改？

你的数据到底是列还是行？改了以后再改回来又得费劲。

lwcx8899

chxw68 发表于 2014-4-23 18:58
你的数据到底是列还是行？改了以后再改回来又得费劲。

谢谢，按行取数。