如何按部门展示每个职级的人员情况

飞天篮球猪

gaozengxun 发表于 2024-6-8 10:26
你这个公式看不懂，能解释一下吗，是不是传说中PQ

有兴趣可以去了解一下润乾集算器。
PQ的效率跟预期不符，已经好几年没玩了。

gaozengxun

可以用公式搞定
F7=UNIQUE($C$2:$C$11)（支持动态公式的更简单，否则可用=INDEX(UNIQUE($C$2:$C$11),ROW(A1))，向下拉）

G7=IFERROR(TEXTJOIN("、",1,FILTER($A$2:$A$11,($B$2:$B$11=G$6)*($C$2:$C$11=$F7))),"")向下和向右拉即可。

wsx22

准提部林老师、向老师：如原表格有重复字段，即重复出现A列、B列、C列一样情况下，A列结果有重复字段，能否直接得出不重复字段，请教如何修订代码，谢谢！

Qs18

试试.......

Qs18

Sub test()
Dim arr: arr = Sheet1.Range("a1").CurrentRegion.Value
Dim dic: Set dic = CreateObject("scripting.dictionary")
Dim dic2: Set dic2 = CreateObject("scripting.dictionary")
Dim dic3: Set dic3 = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
    s = arr(i, 3): s2 = arr(i, 2): ss = s & s2
    If Not dic.exists(s) Then dic(s) = ""
    If Not dic2.exists(s2) Then dic2(s2) = ""
    If Not dic3.exists(ss) Then
        dic3(ss) = arr(i, 1)
    Else
        dic3(ss) = dic3(ss) & "；" & arr(i, 1)
    End If
Next i
ReDim crr(1 To dic.Count + 1, 1 To dic2.Count + 1)
crr(1, 1) = "职级"
m = 1
For Each k In dic.keys
    m = m + 1
    crr(m, 1) = k
Next
n = 1
For Each k2 In dic2.keys
    n = n + 1
    crr(1, n) = k2
Next
For x = 2 To UBound(crr)
    For y = 2 To UBound(crr, 2)
        t = crr(x, 1) & crr(1, y)
        crr(x, y) = dic3(t)
   
    Next y
Next
Sheet1.Range("f10").Resize(UBound(crr), UBound(crr, 2)) = crr
MsgBox "完成！"
End Sub

Qs18

试一下.............