按关键字分类汇总上报价、合同价、审核价、结算价

李伟杰123

按关键字分类汇总上报价、合同价、审核价、结算价。

关键字：分包人信息
如下图：已经把【报审价】汇总好了，再添加个程序模块，实现功能：点击“分类汇总”按钮，按分包人汇总各自的报审价、合同价、审核价、结算价。
注意：价格信息要从【表一】引用。

按分包人分类汇总上报价、合同价、审核价、结算价.rar (40.28 KB, 下载次数: 9)

2024-10-29 16:32 上传

点击文件名下载附件

liulang0808

Sub ykcbf() '//2024.5.13
    Set d = CreateObject("Scripting.Dictionary")
    Set d1 = CreateObject("Scripting.Dictionary")
    arr = Sheets("分包人").UsedRange
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        If s <> Empty Then d1(s) = ""
    Next
    With Sheets("表一")
        r = .Cells(Rows.Count, 2).End(3).Row
        arr = .[A1].Resize(r, 8)
        For Each k In d1.keys
            For i = 3 To UBound(arr)
                If Val(arr(i, 1)) = 0 Then
                    If InStr(arr(i, 2), k) Then
                        s = arr(i, 2)
                        If Not d.exists(k) Then Set d(k) = CreateObject("Scripting.Dictionary")
                        d(k)(s) = Array(arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7))
                    End If
                End If
            Next
        Next
    End With
    ReDim brr(1 To 1000, 1 To 6)
    For Each k In d.keys
        Sum1 = 0
        Sum2 = 0
        Sum3 = 0
        Sum4 = 0
        For Each kk In d(k).keys
            m = m + 1
            brr(m, 1) = kk
            brr(m, 2) = k
            crr = d(k)(kk)
            brr(m, 3) = crr(0)
            brr(m, 4) = crr(1)
            brr(m, 5) = crr(2)
            brr(m, 6) = crr(3)
            Sum1 = Sum1 + brr(m, 3)
            Sum2 = Sum2 + brr(m, 4)
            Sum3 = Sum3 + brr(m, 5)
            Sum4 = Sum4 + brr(m, 6)
        Next
        m = m + 1
        brr(m, 2) = k
        brr(m, 3) = Sum1
        brr(m, 4) = Sum2
        brr(m, 5) = Sum3
        brr(m, 6) = Sum4
    Next
    With Sheets("分类汇总表")
        .[b2:g1000] = ""
        .[b2].Resize(m, 6) = brr
    End With
    Set d = Nothing
    Set d1 = Nothing
    MsgBox "OK！"
End Sub

liulang0808

原来代码基础上修改的，楼主看下是否合适吧，部分内容可以用数组进一步简化

李伟杰123

liulang0808 发表于 2024-10-29 19:27
原来代码基础上修改的，楼主看下是否合适吧，部分内容可以用数组进一步简化

好像不行，没有结果

liulang0808

李伟杰123 发表于 2024-10-30 09:04
好像不行，没有结果

这个不是结果吗？

李伟杰123

liulang0808 发表于 2024-10-30 10:02
这个不是结果吗？

点击【分类汇总】按钮，红色内容就没有了

liulang0808

李伟杰123 发表于 2024-10-30 10:23
点击【分类汇总】按钮，红色内容就没有了

原来的按钮没有指定宏的，重新指定了，楼主看看是否可行吧

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. brr = Sheet2.Range("a1").CurrentRegion.Value
   
5.     For i = 2 To UBound(brr)
   
6.         dic(brr(i, 1)) = ""
   
7.     Next
   
8. arr = Sheet1.[a1].CurrentRegion.Value
   
9. ReDim crr(1 To UBound(arr), 1 To 6)
   
10. For Each k In dic.keys
    
11.     m = 0: s1 = 0: s2 = 0: s3 = 0: s4 = 0
    
12.    For i = 4 To UBound(arr)
    
13.         If InStr(arr(i, 2), k) Then
    
14.             m = m + 1
    
15.             crr(m, 1) = arr(i, 2): crr(m, 2) = k
    
16.             For j = 4 To 7
    
17.                 crr(m, j - 1) = arr(i, j)
    
18.             Next
    
19.             s1 = s1 + crr(m, 3): s2 = s2 + crr(m, 4): s3 = s3 + crr(m, 5): s4 = s4 + crr(m, 6)
    
20.         End If
    
21.    Next i
    
22. If m > 0 Then
    
23. With Sheet3
    
24. rw = .[b1].CurrentRegion.Rows.Count + 1
    
25.     .Range("b" & rw).Resize(m, 6) = crr
    
26.     .Range("c" & rw + m) = crr(1, 2): .Range("d" & rw + m) = s1: .Range("e" & rw + m) = s2
    
27.     .Range("f" & rw + m) = s3: .Range("g" & rw + m) = s4
    
28. End With
    
29. End If
    
30. Next k
    
31. Set dic = Nothing
    
32. End Sub

复制代码

Qs18

试试.......

Qs18

试试.........