按关键字分类汇总

李伟杰123

按分包人分类汇总造价
表一：


分包人字典：



分类结果：

按分包人排序汇总.rar (15.76 KB, 下载次数: 24)

2024-5-13 09:39 上传

点击文件名下载附件

cnmlgb9998

PQ 方案完美解决。。。。。。。。。。香不香？？？？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.5.13
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("分包人").UsedRange
   
5.     For i = 2 To UBound(arr)
   
6.         s = arr(i, 1)
   
7.         If s <> Empty Then d1(s) = ""
   
8.     Next
   
9.     With Sheets("表一")
   
10.         r = .Cells(Rows.Count, 2).End(3).Row
    
11.         arr = .[a1].Resize(r, 4)
    
12.         For Each k In d1.keys
    
13.             For i = 3 To UBound(arr)
    
14.                 If Val(arr(i, 1)) = 0 Then
    
15.                     If InStr(arr(i, 2), k) Then
    
16.                         s = arr(i, 2)
    
17.                         If Not d.exists(k) Then Set d(k) = CreateObject("Scripting.Dictionary")
    
18.                         d(k)(s) = arr(i, 4)
    
19.                     End If
    
20.                 End If
    
21.             Next
    
22.         Next
    
23.     End With
    
24.     ReDim brr(1 To 1000, 1 To 3)
    
25.     For Each k In d.keys
    
26.         Sum = 0
    
27.         For Each kk In d(k).keys
    
28.             m = m + 1
    
29.             brr(m, 1) = kk
    
30.             brr(m, 2) = k
    
31.             brr(m, 3) = d(k)(kk)
    
32.             Sum = Sum + brr(m, 3)
    
33.         Next
    
34.         m = m + 1
    
35.         brr(m, 2) = k
    
36.         brr(m, 3) = Sum
    
37.     Next
    
38.     With Sheets("分类汇总表")
    
39.         .[b2:g1000] = ""
    
40.         .[b2].Resize(m, 3) = brr
    
41.     End With
    
42.     Set d = Nothing
    
43.     Set d1 = Nothing
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

yanglinzi

1. Sub 按分包人汇总()
   
2. Dim arr, brr, i, j, r, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet2.UsedRange
   
5. For i = 2 To UBound(arr)
   
6.     sa = arr(i, 1)
   
7.     d(sa) = ""
   
8. Next
   
9. With Sheet1
   
10.     r = .Cells(Rows.Count, 2).End(xlUp).Row
    
11.     brr = .Range("a2：g" & r)
    
12. End With
    
13. ReDim crr(1 To UBound(brr), 1 To 7)
    
14. For j = 2 To UBound(brr)
    
15.     If InStr(brr(j, 2), "月") = 0 Then
    
16.         For Each k In d.keys
    
17.             If InStr(brr(j, 2), k) Then
    
18.                 n = n + 1
    
19.                 crr(n, 1) = ""
    
20.                 crr(n, 2) = brr(j, 2)
    
21.                 crr(n, 3) = k
    
22.                 crr(n, 4) = brr(j, 4)
    
23.                 crr(n, 5) = brr(j, 5)
    
24.                 crr(n, 6) = brr(j, 6)
    
25.                 crr(n, 7) = brr(j, 7)
    
26.             End If
    
27.         Next
    
28.     End If
    
29. Next
    
30. With Sheet4
    
31.     .UsedRange.Offset(1).ClearContents
    
32.     .[a2].Resize(n, 7) = crr
    
33.     Set Rng = Range("b2").Resize(n, 6)
    
34.     Rng.Sort [c1], Header:=xlYes
    
35.     r = .Cells(Rows.Count, 2).End(xlUp).Row
    
36.     For j = r To 2 Step -1
    
37.         For i = j - 1 To 1 Step -1
    
38.             If .Cells(j, 3) <> .Cells(i, 3) Then
    
39.                 .Rows(j + 1).Insert
    
40.                 .Cells(j + 1, 3) = .Cells(j, 3)
    
41.                 .Cells(j + 1, 4) = Application.Sum(Range(.Cells(i + 1, 4), .Cells(j, 4)))
    
42.                 j = i
    
43.             End If
    
44.         Next
    
45.     Next
    
46. End With
    
47. End Sub
    

复制代码

limonet

关键字：like

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select a.工程项目,b.分包人,报审价 From [表一$B2:D]a Left join [分包人$]b On a.工程项目 like '%'+b.分包人+'%' Where not b.分包人 is Null"
    StrSQL = "Select 工程项目,分包人,报审价 From (" & StrSQL & ") Union ALl Select 分包人&'小计',分包人,Sum(报审价) From (" & StrSQL & ") Group By 分包人"
    StrSQL = "Select * From (" & StrSQL & ") Order By 分包人 Desc,报审价 asc"
    Range("B2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

yanglinzi

参与一下。。

ooluckydog

LIUZHU

这个效果吗？