[已解决]字典有没有办法直接按求出的唯一代码汇总

jkczfpb

QnOzlZEy.rar (793.96 KB, 下载次数: 44)

2008-12-3 22:34 上传

点击文件名下载附件
字典有没有办法直接按求出的唯一代码汇总
用字典求出了唯一主代码，然后根据主代码汇总，我按公式求的，现想用字典直接装，怎么弄

还有怎样对求出的唯一代码排序后输出

最佳答案

月排行榜 / 总排行榜

oobird

2008-12-3 23:58

Sub zwgk_d2()
Dim d As Object, rng, i%, m%, arr
Set d = CreateObject("Scripting.Dictionary")
With Sheets(4)
rng = .Range(.[k1], .[m1].End(4))
End With
ReDim arr(1 To UBound(rng), 1 To 2)
For i = 1 To UBound(rng)
w = Left(rng(i, 3), 8)
If d(w) = "" Then
m = m + 1
d(w) = m
arr(m, 1) = rng(i, 1): arr(m, 2) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
Next i
With Sheets(2)
.[a1].Resize(m, 2) = arr
End With
End Sub

跳转到最佳答案楼层

oobird

Sub zwgk_d2()
Dim d As Object, rng, i%, m%, arr
Set d = CreateObject("Scripting.Dictionary")
With Sheets(4)
rng = .Range(.[k1], .[m1].End(4))
End With
ReDim arr(1 To UBound(rng), 1 To 2)
For i = 1 To UBound(rng)
w = Left(rng(i, 3), 8)
If d(w) = "" Then
m = m + 1
d(w) = m
arr(m, 1) = rng(i, 1): arr(m, 2) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
Next i
With Sheets(2)
.[a1].Resize(m, 2) = arr
End With
End Sub

jkczfpb

非常感谢，汇总功能实现，但能否加上代码注释，便于学习

能否提取的同时排序

oobird

写入单元格后再排序才是最高效率的。

每句都很浅显且都是论场中常见的，哪句须要注释呢？

jkczfpb

由于金额要放在 H 列，代码放在 K 列，所以我改成了这样，但我想在I列增加根据代码查询的一个项目，怎么改

Sub zwgk_d22()       Dim d As Object, rng, i%, m%, arr
Set d = CreateObject("Scripting.Dictionary")
With Sheets(4)
rng = .Range(.[k2], .[m2].End(4))
End With
ReDim arr(1 To UBound(rng), 1 To 4)
For i = 1 To UBound(rng)
w = Left(rng(i, 3), 8)
If d(w) = "" Then
m = m + 1
d(w) = m
arr(m, 1) = rng(i, 1): arr(m, 4) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
Next i
With Sheets(2)
.[g2].Resize(m, 4) = arr
End With
End Sub

jkczfpb

完全不懂代码，既然实现了功能，还是洗完昂注释一下（代码除外）

Sub zwgk_d22()        '请教得来，取分配表代码
Dim d As Object, rng, i%, m%, y%, arr '声明一个对象变量来存放该对象的引用。Dim as Object 采用后期绑定方式。
Set d = CreateObject("Scripting.Dictionary")
With Sheets(4)
rng = .Range(.[k2], .[m2].End(4))
End With
ReDim arr(1 To UBound(rng), 1 To 4)
For i = 1 To UBound(rng)
w = Left(rng(i, 3), 8)
If d(w) = "" Then
m = m + 1
d(w) = m
arr(m, 1) = rng(i, 1): arr(m, 2) = rng(i, 2): arr(m, 4) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
Next i
With Sheets(2)
.[g2].Resize(m, 4) = arr
End With
End Sub

jkczfpb

E列和J列数据一样，我这样改怎么其他行数据正确，J列却提取的第一个数据，而不是和E列一样是和，是完成后

让J列等于E列，还是怎么改？

Sub zwgk_d22()       

Dim d As Object, rng, i%, m%, y%, arr
Set d = CreateObject("Scripting.Dictionary")
With Sheets(4)
rng = .Range(.[k2], .[m2].End(4))
End With
ReDim arr(1 To UBound(rng), 1 To 6)
For i = 1 To UBound(rng)
w = Left(rng(i, 3), 8)
If d(w) = "" Then
m = m + 1
d(w) = m
 arr(m, 1) = rng(i, 1): arr(m, 2) = 0:  arr(m, 4) = rng(i, 2): arr(m, 6) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
Next i
With Sheets(2)
.[e2].Resize(m, 6) = arr
End With
End Sub

jkczfpb

我想通过实例学习VBA，请提供代码的同时加上注释

青城山苦丁茶

不晓得目的是啥。

If d(w) = "" Then
m = m + 1
d(w) = m
 arr(m, 1) = rng(i, 1): arr(m, 2) = 0:  arr(m, 4) = rng(i, 2): arr(m, 6) = "'" & w & "0000"
Else
arr(d(w), 1) = arr(d(w), 1) + rng(i, 1)
End If
的作用是第一次出现的值w，则将相应的rng值写入数组arr成为一条新的记录；对于重复出现的值w，则将rng的值累加到数组arr上（只累加到了相应arr记录的第一列上，其它值则不变）

[此贴子已经被作者于2008-12-4 21:33:58编辑过]

jkczfpb

如果累加其他列，怎么办呢？

同时有几列需要累加怎么办呢？