[已解决]（2017年的第一次求助）字典实现分类汇总至新表

hefeilac

（求助）字典分类汇总至新表.rar (39.79 KB, 下载次数: 29)

2017-1-22 15:48 上传

点击文件名下载附件
需要达到的效果已经手工做了一次，且有公式，让大神了解之间的关系
希望能得到大神的帮助！感谢！

最佳答案

月排行榜 / 总排行榜

蓝桥玄霜

2017-2-2 20:21

请见代码。

跳转到最佳答案楼层

hefeilac

双条件字典查找分类汇总，并循环出有填充色的分项名称和构件名称，把汇总结果放在其中
大神呢？好期待啊！

研究研究

If Not dic.Exists(条件1 & 条件2 ) Then  

蓝桥玄霜

为什么工程量列中有的公式中除1000，有的没有除1000的？

蓝桥玄霜

请见代码。

雄鹰2013

Sub 汇总()
Dim arr, j, l, brr(1 To 1000, 1 To 7)
ar = Array(2, 4, 21, 22, 23, 24)
With Sheets("结构明细表")
r = .[f65536].End(3).Row
arr = .Range("a1:ac" & r)
For i = 3 To UBound(arr)
     For ii = 0 To UBound(ar)
         j = ar(ii)
         If .Cells(i, j) <> "" Then
            n = n + 1
            Select Case j
                   Case 2
                   l = 1
                   Case 4
                   l = 2
                   Case Else
                   l = 3
            End Select
            If .Cells(i, j).Interior.ColorIndex <> -4142 Then '-4142表示无色
               l2 = 14 'N列（总重）
            Else
               l2 = j + 4
            End If
            brr(n, l) = arr(i, j)
            brr(n, 5) = Round(arr(i, l2) / 1000, 2)
            brr(n, 6) = arr(i, 29)
            brr(n, 7) = arr(i, 16)
         End If
     Next ii
Next i
End With
Sheets("构件材料分析表").[a23].Resize(n, 7) = brr
End Sub

雄鹰2013

Sub 汇总2()
Dim arr, j, l, brr(1 To 1000, 1 To 7)
ar = Array(2, 4, 21, 22, 23, 24)
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
t = Timer
With Sheets("结构明细表")
r = .[f65536].End(3).Row
arr = .Range("a1:ac" & r)
For i = 3 To UBound(arr)
     For ii = 0 To UBound(ar)
         j = ar(ii)
         If .Cells(i, j) <> "" Then
            l = IIf(j = 2, 1, IIf(j = 4, 2, 3))
            If .Cells(i, j).Interior.ColorIndex <> -4142 Then '-4142表示无色
               l2 = 14 'N列（总重）
               d.RemoveAll
            Else
               l2 = j + 4
            End If
            If Not d.exists(arr(i, j)) Then
               n = n + 1
               d(arr(i, j)) = n
               brr(n, l) = arr(i, j)
               brr(n, 5) = Round(arr(i, l2) / 1000, 2)
               brr(n, 6) = arr(i, 29)
               brr(n, 7) = arr(i, 16)
            Else
               m = d(arr(i, j))
               brr(m, 5) = brr(m, 5) + Round(arr(i, l2) / 1000, 2)
            End If
         End If
     Next ii
Next i
End With
With Sheets("构件材料分析表")
     .Rows("23:100").ClearContents
     .[a23].Resize(n, 7) = brr
End With
MsgBox Format(Timer - t, "0.00秒")
Application.ScreenUpdating = True
End Sub

雄鹰2013

提供合并与不合并两种思路，仅供参考