[已解决]求段代码

fgt258 · 发表于 2012-10-13 11:14

要求样式见附件在此谢谢各位了

最佳答案

huoxieshen

2012-10-13 12:19

fgt258 发表于 2012-10-13 12:14
编号提取不重复,相对应编号的 "数量,金额" 累加 ;; "重量,去向" 照搬(因为他们都是一样的,只要和编号对 ...

看看这样可以不？？

Sub LK()
g = Timer
Dim i As Long, arr(), brr(1 To 60000, 1 To 5), k As Long, h As Long, d As Object
Set d = CreateObject("SCRIPTING.DICTIONARY")
r = Cells(Rows.Count, 1).End(3).Row
arr = Range("a2:e" & r).Value
For i = 1 To r - 1
If d.Exists(arr(i, 1)) Then
h = d(arr(i, 1))
brr(h, 2) = brr(h, 2) + arr(i, 2)
brr(h, 4) = brr(h, 4) + arr(i, 5)
Else
k = k + 1
d(arr(i, 1)) = k
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 3)
brr(k, 4) = arr(i, 5)
brr(k, 5) = arr(i, 4)
End If
Next
Range("g2:k65536").ClearContents
Range("g2").Resize(k, 5) = brr
MsgBox Timer - g
End Sub

复制代码

wk0316 · 发表于 2012-10-13 11:37

楼至直接应用技巧就行了，不用这么麻烦，筛选不重复项就可以了，其他的用函数实现。

fgt258 · 发表于 2012-10-13 11:46

wk0316 发表于 2012-10-13 11:37
楼至直接应用技巧就行了，不用这么麻烦，筛选不重复项就可以了，其他的用函数实现。

数据是分两个工作簿存的,量较大,还存在条件,所以用公式不适合,,还请多多帮忙,,,谢谢

huoxieshen · 发表于 2012-10-13 11:52

fgt258 发表于 2012-10-13 11:46
数据是分两个工作簿存的,量较大,还存在条件,所以用公式不适合,,还请多多帮忙,,,谢谢

你的附件里不是有段字典去重的代码了么？？你还要什么？？

fgt258 · 发表于 2012-10-13 11:56

huoxieshen 发表于 2012-10-13 11:52
你的附件里不是有段字典去重的代码了么？？你还要什么？？

那段字典只是提了不重复值,,,还是数据累加,和直接引用处理不了,, 字典ITEM 只能处理一项还有三项不知如何处理

huoxieshen · 发表于 2012-10-13 12:05

fgt258 发表于 2012-10-13 11:56
那段字典只是提了不重复值,,,还是数据累加,和直接引用处理不了,, 字典ITEM 只能处理一项还有三项不知 ...

数量是哪一列累加？？编号？？还有需要颜色么？？

fgt258 · 发表于 2012-10-13 12:14

本帖最后由 fgt258 于 2012-10-13 12:18 编辑

huoxieshen 发表于 2012-10-13 12:05
数量是哪一列累加？？编号？？还有需要颜色么？？

编号提取不重复,相对应编号的 "数量,金额" 累加 ;; "重量,去向" 照搬(因为他们都是一样的,只要和编号对应就行) ,,颜色就不用了

huoxieshen · 发表于 2012-10-13 12:19

fgt258 发表于 2012-10-13 12:14
编号提取不重复,相对应编号的 "数量,金额" 累加 ;; "重量,去向" 照搬(因为他们都是一样的,只要和编号对 ...

看看这样可以不？？

Sub LK()
g = Timer
Dim i As Long, arr(), brr(1 To 60000, 1 To 5), k As Long, h As Long, d As Object
Set d = CreateObject("SCRIPTING.DICTIONARY")
r = Cells(Rows.Count, 1).End(3).Row
arr = Range("a2:e" & r).Value
For i = 1 To r - 1
If d.Exists(arr(i, 1)) Then
h = d(arr(i, 1))
brr(h, 2) = brr(h, 2) + arr(i, 2)
brr(h, 4) = brr(h, 4) + arr(i, 5)
Else
k = k + 1
d(arr(i, 1)) = k
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 3)
brr(k, 4) = arr(i, 5)
brr(k, 5) = arr(i, 4)
End If
Next
Range("g2:k65536").ClearContents
Range("g2").Resize(k, 5) = brr
MsgBox Timer - g
End Sub

复制代码

fgt258 · 发表于 2012-10-13 12:44

huoxieshen 发表于 2012-10-13 12:19
看看这样可以不？？

非常感谢,,现在知道怎么定位某个数据的位置了

		自动登录	找回密码
密码			注册