统计每个产品的客户（不重复）

哒哒哒是的撒多

工作簿1.zip (23.79 KB, 下载次数: 13)

2023-3-7 14:55 上传

点击文件名下载附件

chxw68

详见附件。

gwjkkkkk

请参考。。。

洋务德雷

不用编程vba，只要用SQL——透视表显示就可以做到了。简单快捷方便

renkangjizhen

多字典一次搞定，代码如下：
Sub TJ()
Dim i%, m%, n%, d1, d2, k, brr, d3, x%
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
i = [b65536].End(3).Row
For m = 2 To i
If Not d1.exists(Cells(m, 2).Value) Then
d1(Cells(m, 2).Value) = 1
Else
d1(Cells(m, 2).Value) = d1(Cells(m, 2).Value) + 1
End If
If Not d2.exists(Cells(m, 2).Value) Then
d2(Cells(m, 2).Value) = Cells(m, 3).Value
Else
d2(Cells(m, 2).Value) = d2(Cells(m, 2).Value) & "," & Cells(m, 3).Value
End If
Next
[e2].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.keys)
[f2].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.items)
For n = 2 To d1.Count + 1
brr = Split(d2(Cells(n, 5).Value), ",")
For x = 0 To UBound(brr)
If Not d3.exists(brr(x)) Then
d3(brr(x)) = ""
End If
Next
Cells(n, 7).Resize(1, d3.Count) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d3.keys))
Next
End Sub

renkangjizhen

附件如下：

xunanming

请楼主参考是否满足需求.

tanglf188

练手

准提部林

Sub TEST_A1()
Dim Arr, Brr, xD, i&, T1$, T2$, TT$, R&, N&
Set xD = CreateObject("scripting.dictionary")
Arr = Range([a1], Cells(Rows.Count, 3).End(3))
ReDim Brr(1 To UBound(Arr), 1 To 3)
For i = 2 To UBound(Arr)
    T1 = Arr(i, 2): T2 = Arr(i, 3): TT = T1 & "|" & T2
    If xD(TT) > 0 Then GoTo i01
    R = xD(T1):  xD(TT) = 1
    If R = 0 Then N = N + 1: R = N: Brr(N, 1) = T1: xD(T1) = N
    Brr(R, 2) = Brr(R, 2) + 1
    Brr(R, 3) = Brr(R, 3) & IIf(Brr(R, 3) = "", "", "/") & T2
i01: Next i
[e2].Resize(N, 3) = Brr
End Sub