按关键字分类汇总

李伟杰123 · 发表于 2024-5-13 09:39

本帖最后由李伟杰123 于 2024-5-13 09:39 编辑

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

搜狗截图20240511173324.jpg

分包人字典：

分类结果：

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

cnmlgb9998 · 发表于 2024-5-13 10:32

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

ykcbf1100 · 发表于 2024-5-13 10:32

附件供参考。。。

ykcbf1100 · 发表于 2024-5-13 10:33

参与一下。。。

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, 4)
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) = arr(i, 4)
End If
End If
Next
Next
End With
ReDim brr(1 To 1000, 1 To 3)
For Each k In d.keys
Sum = 0
For Each kk In d(k).keys
m = m + 1
brr(m, 1) = kk
brr(m, 2) = k
brr(m, 3) = d(k)(kk)
Sum = Sum + brr(m, 3)
Next
m = m + 1
brr(m, 2) = k
brr(m, 3) = Sum
Next
With Sheets("分类汇总表")
.[b2:g1000] = ""
.[b2].Resize(m, 3) = brr
End With
Set d = Nothing
Set d1 = Nothing
MsgBox "OK！"
End Sub

复制代码

yanglinzi · 发表于 2024-5-13 10:34

Sub 按分包人汇总()
Dim arr, brr, i, j, r, d
Set d = CreateObject("scripting.dictionary")
arr = Sheet2.UsedRange
For i = 2 To UBound(arr)
sa = arr(i, 1)
d(sa) = ""
Next
With Sheet1
r = .Cells(Rows.Count, 2).End(xlUp).Row
brr = .Range("a2：g" & r)
End With
ReDim crr(1 To UBound(brr), 1 To 7)
For j = 2 To UBound(brr)
If InStr(brr(j, 2), "月") = 0 Then
For Each k In d.keys
If InStr(brr(j, 2), k) Then
n = n + 1
crr(n, 1) = ""
crr(n, 2) = brr(j, 2)
crr(n, 3) = k
crr(n, 4) = brr(j, 4)
crr(n, 5) = brr(j, 5)
crr(n, 6) = brr(j, 6)
crr(n, 7) = brr(j, 7)
End If
Next
End If
Next
With Sheet4
.UsedRange.Offset(1).ClearContents
.[a2].Resize(n, 7) = crr
Set Rng = Range("b2").Resize(n, 6)
Rng.Sort [c1], Header:=xlYes
r = .Cells(Rows.Count, 2).End(xlUp).Row
For j = r To 2 Step -1
For i = j - 1 To 1 Step -1
If .Cells(j, 3) <> .Cells(i, 3) Then
.Rows(j + 1).Insert
.Cells(j + 1, 3) = .Cells(j, 3)
.Cells(j + 1, 4) = Application.Sum(Range(.Cells(i + 1, 4), .Cells(j, 4)))
j = i
End If
Next
Next
End With
End Sub

复制代码

limonet · 发表于 2024-5-13 10:34

关键字：like

limonet · 发表于 2024-5-13 10:35

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 · 发表于 2024-5-13 10:37

参与一下。。

ooluckydog · 发表于 2024-5-13 10:57

LIUZHU · 发表于 2024-5-13 11:14

这个效果吗？

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

[求助] 按关键字分类汇总

评分

评分

评分

评分