求解条件汇总

fbata · 发表于 2013-5-14 13:27

斑主 /高手们，帮我看看附档那个如何解决哦，用简单易懂方法吧，别编得太深奥了哦
刚刚想看看VBA好不好学哦
谢谢！拜托了{:soso_e112:}

lijiawu1122 · 发表于 2013-5-14 14:25

用数据透视表就可以了

grf1973 · 发表于 2013-5-14 21:07

Sub tt()
Set d1 = CreateObject("scripting.dictionary") '供方
Set d2 = CreateObject("scripting.dictionary") '供方全，用以计算实数（全）
Set d3 = CreateObject("scripting.dictionary") '供方全，用以计算工合计（全）
r = Sheet1.[a65536].End(3).Row
arr = Sheet1.Range("a5:r" & r)
For i = 1 To UBound(arr)
d1(arr(i, 2)) = ""
d2(arr(i, 2) & arr(i, 18)) = d2(arr(i, 2) & arr(i, 18)) + arr(i, 9) '供方+方式，“实数”累加
d3(arr(i, 2) & arr(i, 18)) = d3(arr(i, 2) & arr(i, 18)) + arr(i, 17) '供方+方式，“工合计”累加
Next
brr = d1.keys
keyd2 = d2.keys: itemd2 = d2.items
itemd3 = d3.items
Set sh = Sheet1
With Sheet3
.Range("a3:O100").ClearContents
Dim crr(1 To 15) '汇总每行（共15列）
For i = 0 To UBound(brr)
crr(13) = 0: crr(14) = 0: crr(15) = 0 '由于并不是所有供方都有“全”方式，因此第13、14、15列赋初值0
xr = i + 3 '所要填的行
crr(1) = i + 1 '序号
crr(2) = brr(i) '供方
For j = 3 To 12 '标数、实数。。。。。。。、工合计
crr(j) = Application.SumIf(sh.Range("b5:b" & r), brr(i), sh.Range(sh.Cells(5, j + 5), sh.Cells(r, j + 5)))
Next
For k = 0 To UBound(keyd2)
If keyd2(k) = brr(i) & "全" Then '如果条件为“供方全”，得到“实数”、“工合计”、“方式”
crr(13) = itemd2(k)
crr(14) = itemd3(k)
If crr(13) <> 0 Then crr(15) = Format(crr(14) / crr(13), "0.00%")
End If
Next
.Cells(xr, 1).Resize(1, 15) = crr '填充
Next
.Range("B3:O" & xr).Sort Key1:=.Range("B3"), Order1:=xlAscending '按供方排序
End With
End Sub

复制代码

见附件，体现在Sheet3里

fbata · 发表于 2013-5-15 13:42

lijiawu1122 发表于 2013-5-14 14:25
用数据透视表就可以了

感谢你的帮忙！

fbata · 发表于 2013-5-15 13:49

grf1973 发表于 2013-5-14 21:07
见附件，体现在Sheet3里

非常感谢1973！太帅了
对里面的好多语句看不懂哦！别笑哦，刚想了解VBA哦

grf1973 · 发表于 2013-5-15 14:55

本来读程序比编程序要难一点。建议学一下字典，编程很有用的。

fbata · 发表于 2013-5-21 12:49

谢谢grf1973

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

求解 条件 汇总

评分

求解条件汇总