越来越难，无从下手。

1643688477

sheet b 做成sheet b2的样子。确实是难。能力所不及，求教了。

cjc209

我看了半天 这有什么难度 就是以明细分组聚合

ykcbf1100

不难吧，用字典就行。

15899681383

公式版公式版公式版公式版公式版

ykcbf1100

用字典解决。

1. Sub ykcbf()   '//2024.12.13
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("B")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 8)
   
7.     End With
   
8.     ReDim brr(1 To r, 1 To 8)
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 3)
    
11.         If Not d.exists(s) Then
    
12.             m = m + 1
    
13.             d(s) = m
    
14.             For j = 1 To UBound(arr, 2)
    
15.                 brr(m, j) = arr(i, j)
    
16.             Next
    
17.         Else
    
18.             r = d(s)
    
19.             brr(r, 1) = IIf(InStr(brr(r, 1), arr(i, 1)), brr(r, 1), brr(r, 1) & "," & arr(i, 1))
    
20.             brr(r, 2) = IIf(InStr(brr(r, 2), arr(i, 2)), brr(r, 2), brr(r, 2) & "|" & arr(i, 2))
    
21.             brr(r, 5) = brr(r, 5) + arr(i, 5)
    
22.             brr(r, 6) = brr(r, 6) + arr(i, 6)
    
23.         End If
    
24.     Next
    
25.     With Sheets("B2")
    
26.         .UsedRange.Offset(1).ClearContents
    
27.         .[a2].Resize(m, 8) = brr
    
28.         .[a2].Resize(m, 8).Borders.LineStyle = 1
    
29.     End With
    
30.     Set d = Nothing
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码

15899681383

这个用VBA大材小用了，公式也很简单

ykcbf1100

15899681383 发表于 2024-12-13 15:55
公式版公式版公式版公式版公式版

现在公式都这么强了吗？

15899681383

ykcbf1100 发表于 2024-12-13 16:40
现在公式都这么强了吗？

是的啊，现在新出来得有些函数公式挺实用得

cnmlgb9998

PQ方案。简单，快捷，还能自动更新。。。。。。