[已解决]帮忙修改代码

雄鹰2013

附件中的代码没有将类型相同的归到一下，如何修改一下

最佳答案

月排行榜 / 总排行榜

grf1973

2015-1-28 15:37

换个思路

1. Sub 提取数据()
   
2.     Dim arr, brr(1 To 100, 1 To 7)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Range("a1").CurrentRegion
   
6.     For i = 1 To UBound(arr)
   
7.         zf = arr(i, 3) & "," & arr(i, 6) '物料和单价相同
   
8.         If Not d.exists(zf) Then
   
9.             x = x + 1
   
10.             d(zf) = x
    
11.             For j = 1 To UBound(arr, 2)
    
12.                 brr(x, j) = arr(i, j)
    
13.             Next j
    
14.             d1(brr(x, 2)) = d1(brr(x, 2)) & "," & x
    
15.         Else
    
16.             p = d(zf)
    
17.             brr(p, 5) = brr(p, 5) + arr(i, 5)
    
18.             brr(p, 7) = brr(p, 7) + arr(i, 7)
    
19.         End If
    
20.     Next
    
21.    
    
22.     crr = brr: x = Join(d1.items)
    
23.     xrr = Split(x, ",")
    
24.     For j = 2 To UBound(xrr)    '去掉第0个空位，第1个表头
    
25.         t = Val(xrr(j)): n = n + 1
    
26.         crr(n + 1, 1) = n
    
27.         For k = 2 To UBound(brr, 2)
    
28.             crr(n + 1, k) = brr(t, k)
    
29.         Next
    
30.     Next
    
31.     Range("i1").CurrentRegion.ClearContents
    
32.     Range("i1").Resize(n + 1, 7) = crr
    
33. End Sub

复制代码

跳转到最佳答案楼层

爱疯

添加到代码末尾

Range("i1").CurrentRegion.Sort [j1], 1, , , , , , xlYes
Range("i2") = 1
Range("i2").AutoFill Range("i2:i" & x), xlFillSeries

雄鹰2013

能否在数组里进行修改

grf1973

其实在工作表里排序是最简单的做法。如果非要在数组里搞，可参考：

1. Sub 提取数据()
   
2.     Dim arr, brr(1 To 100, 1 To 7)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Range("a1").CurrentRegion
   
6.     brr(1, 1) = "序号"
   
7.     For i = 1 To UBound(arr)
   
8.         zf = arr(i, 3) & "," & arr(i, 6) '物料和单价相同
   
9.         d1(arr(i, 2)) = ""
   
10.         If Not d.exists(zf) Then
    
11.             x = x + 1
    
12.             d(zf) = x
    
13.             If x > 1 Then brr(x, 1) = x - 1
    
14.             For j = 2 To UBound(arr, 2)
    
15.                 brr(x, j) = arr(i, j)
    
16.             Next j
    
17.         Else
    
18.             brr(d(zf), 5) = brr(d(zf), 5) + arr(i, 5)
    
19.             brr(d(zf), 7) = brr(d(zf), 7) + arr(i, 7)
    
20.         End If
    
21.     Next
    
22.     dk = d1.keys: crr = brr
    
23.     For i = 1 To UBound(dk)
    
24.         For j = 2 To UBound(brr)
    
25.             If brr(j, 2) = dk(i) Then
    
26.                 n = n + 1
    
27.                 crr(n + 1, 1) = n
    
28.                 For k = 2 To UBound(brr, 2)
    
29.                     crr(n + 1, k) = brr(j, k)
    
30.                 Next
    
31.             End If
    
32.         Next
    
33.     Next
    
34.     Range("i1").CurrentRegion.ClearContents
    
35.     Range("i1").Resize(n + 1, 7) = crr
    
36. End Sub
    

复制代码

grf1973

换个思路

1. Sub 提取数据()
   
2.     Dim arr, brr(1 To 100, 1 To 7)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     arr = Range("a1").CurrentRegion
   
6.     For i = 1 To UBound(arr)
   
7.         zf = arr(i, 3) & "," & arr(i, 6) '物料和单价相同
   
8.         If Not d.exists(zf) Then
   
9.             x = x + 1
   
10.             d(zf) = x
    
11.             For j = 1 To UBound(arr, 2)
    
12.                 brr(x, j) = arr(i, j)
    
13.             Next j
    
14.             d1(brr(x, 2)) = d1(brr(x, 2)) & "," & x
    
15.         Else
    
16.             p = d(zf)
    
17.             brr(p, 5) = brr(p, 5) + arr(i, 5)
    
18.             brr(p, 7) = brr(p, 7) + arr(i, 7)
    
19.         End If
    
20.     Next
    
21.    
    
22.     crr = brr: x = Join(d1.items)
    
23.     xrr = Split(x, ",")
    
24.     For j = 2 To UBound(xrr)    '去掉第0个空位，第1个表头
    
25.         t = Val(xrr(j)): n = n + 1
    
26.         crr(n + 1, 1) = n
    
27.         For k = 2 To UBound(brr, 2)
    
28.             crr(n + 1, k) = brr(t, k)
    
29.         Next
    
30.     Next
    
31.     Range("i1").CurrentRegion.ClearContents
    
32.     Range("i1").Resize(n + 1, 7) = crr
    
33. End Sub

复制代码