[已解决]汇总问题, 代码优化

kmcla · 发表于 2017-4-8 15:30

本帖最后由 kmcla 于 2017-4-10 14:53 编辑

好烦啊，用了一天时间，代码有点长，感觉问题难度和长度不批配，比这问题大的都没用这么长

最佳答案

月排行榜 / 总排行榜

grf1973

2017-4-10 10:40

Sub 生成()
Dim sh As Worksheet, CopyRng As Range
Set d = CreateObject("scripting.dictionary")
Set sh = Worksheets("单位")
sh.Range("b4,e4,b9:g28,a9") = ""
sh.Rows("51:1000").Delete
Set CopyRng = sh.Range("a1:g32")
With Sheets("分部")
For i = 5 To .[a65536].End(3).Row Step 50
lx = .Cells(i, "D") '路线
If Len(lx) > 0 Then d(lx) = d(lx) & "," & i
Next
If d.Count = 0 Then Exit Sub
For Each lx In d.keys
r = k * 50 + 1
If k >= 1 Then CopyRng.Copy sh.Cells(r, 1)
sh.Cells(r + 3, 2) = lx
xrr = Split(d(lx), ",")
n = 0: zgc = ""
For i = 1 To UBound(xrr)
r0 = xrr(i)
gc = .Cells(r0, "E") '工程名称
zgc = zgc & "-" & gc '把所有工程用“-”联起来
fs = Application.WorksheetFunction.Average(.Range(.Cells(r0 + 5, 3), .Cells(r0 + 5, 3).End(xlDown))) '平均分
n = n + 1
sh.Cells(r + n + 7, 2) = gc
sh.Cells(r + n + 7, 3) = fs
Next
gcrr = Split(zgc, "-")
sh.Cells(r + 3, 5) = gcrr(1) & "-" & gcrr(UBound(gcrr)) '工程起点--止点
k = k + 1
Next
End With
End Sub

复制代码

跳转到最佳答案楼层

grf1973 · 发表于 2017-4-10 10:40

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

Sub 生成()
Dim sh As Worksheet, CopyRng As Range
Set d = CreateObject("scripting.dictionary")
Set sh = Worksheets("单位")
sh.Range("b4,e4,b9:g28,a9") = ""
sh.Rows("51:1000").Delete
Set CopyRng = sh.Range("a1:g32")
With Sheets("分部")
For i = 5 To .[a65536].End(3).Row Step 50
lx = .Cells(i, "D") '路线
If Len(lx) > 0 Then d(lx) = d(lx) & "," & i
Next
If d.Count = 0 Then Exit Sub
For Each lx In d.keys
r = k * 50 + 1
If k >= 1 Then CopyRng.Copy sh.Cells(r, 1)
sh.Cells(r + 3, 2) = lx
xrr = Split(d(lx), ",")
n = 0: zgc = ""
For i = 1 To UBound(xrr)
r0 = xrr(i)
gc = .Cells(r0, "E") '工程名称
zgc = zgc & "-" & gc '把所有工程用“-”联起来
fs = Application.WorksheetFunction.Average(.Range(.Cells(r0 + 5, 3), .Cells(r0 + 5, 3).End(xlDown))) '平均分
n = n + 1
sh.Cells(r + n + 7, 2) = gc
sh.Cells(r + n + 7, 3) = fs
Next
gcrr = Split(zgc, "-")
sh.Cells(r + 3, 5) = gcrr(1) & "-" & gcrr(UBound(gcrr)) '工程起点--止点
k = k + 1
Next
End With
End Sub

复制代码

kmcla · 发表于 2017-4-10 14:52

grf1973 发表于 2017-4-10 10:40

比我的快，我的短暂假死。
我好好研究下，我以前编的，有好多这类问题，都是用多次计算的笨办法

kmcla · 发表于 2017-4-10 15:12

grf1973 发表于 2017-4-10 10:40

Set CopyRng = sh.Range("a1:g50")
If k >= 1 Then CopyRng.Copy sh.Rows(r)
这种复制，改变了行高，我隐藏起来的单元行，变成不隐藏了
能不能完全按第一组复制
我得复制几干个
问你问题时我想到了，改成这样。
Set CopyRng = sh.Rows("1:50")
你复制这招，比我好多了
我能大大地简化了。

雄鹰2013 · 发表于 2017-8-11 10:55

学习了

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