在同一列数据中如何快速按对应的人员名单统计名字的次数

mind1238

在同一列数据中如何快速按对应的人员名单统计名字的次数

Chip_Kenny

模擬答案上來, 了解一下。

一把小刀闯天下

'你统计表中的名字都有缺失，那就直接生成吧，，，

Option Explicit

Sub test()
  Dim arr, brr, i, j, k, kk, dic, t, tt, m
  Set dic = CreateObject("scripting.dictionary")
  i = [a1].CurrentRegion.Rows.Count
  arr = Range("a1:d" & i)
  For i = 2 To UBound(arr, 1)
    t = arr(i, 1): arr(i, 1) = arr(i, 2)
    arr(i, 2) = t: arr(i, 3) = arr(i, 4)
  Next
  ReDim brr(1 To UBound(arr, 1) * 10, 3)
  For i = 2 To UBound(arr, 1)
    For j = 1 To 3
      If Len(Trim(arr(i, j))) Then
        t = Split(Trim(arr(i, j)), Space(1))
        For k = 0 To UBound(t)
          If Len(t(k)) Then
            tt = Split(t(k), Chr(10))
            For kk = 0 To UBound(tt)
              If Len(tt(kk)) > 0 Then
                If Not dic.exists(tt(kk)) Then
                  m = m + 1: dic(tt(kk)) = m
                  brr(m, 0) = tt(kk)
                End If
                brr(dic(tt(kk)), j) = brr(dic(tt(kk)), j) + 1
              End If
            Next
          End If
        Next
      End If
    Next
  Next
  With [h2]
    With .Resize(UBound(brr, 1), UBound(brr, 2) + 1)
      .Clear
      .Value = brr
    End With
    If m > 0 Then .Resize(m, UBound(brr, 2) + 1).Borders.LineStyle = xlContinuous
  End With
End Sub

mind1238

一把小刀闯天下 发表于 2019-12-18 10:38
'楼主的源数据表很有特色，，，

Option Explicit

谢谢，谢谢，太感谢了
真的好佩服你们
轻而易举就可以做出来了
我对这些数对到想哭
太感谢了

一把小刀闯天下

mind1238 发表于 2019-12-18 10:48
谢谢，谢谢，太感谢了
真的好佩服你们
轻而易举就可以做出来了

刚目测了一下有数据丢失，你统计表中名字边上有空格，源数据表中我倒是给你考虑了，自己修改一下，，，

dic(brr(i, 1)) = i - 1改成：
--------------------
dic(Trim(brr(i, 1))) = i - 1

Chip_Kenny

1. Sub zz()
   
2. Dim a, b, d As Object, k, t, n%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. a = [h1].CurrentRegion.Value
   
5. For i = 2 To UBound(a)
   
6.     d(a(i, 1)) = Array(0, 0, 0)
   
7. Next
   
8. k = d.keys
   
9. b = [a1].CurrentRegion.Value
   
10. For i = 0 To UBound(k)
    
11.     t = d(k(i))
    
12.     For ii = 2 To UBound(b)
    
13.         n = 0
    
14.         For Each j In Array(2, 1, 4)
    
15.             If InStr(b(ii, j), k(i)) Then t(n) = t(n) + 1
    
16.             n = n + 1
    
17.         Next
    
18.     Next
    
19.     d(k(i)) = t
    
20. Next
    
21. [i2].Resize(i, 3) = Application.Transpose(Application.Transpose(d.items))
    
22. End Sub

复制代码

于箱长

一把小刀闯天下 发表于 2019-12-18 10:38
'楼主的源数据表很有特色，，，

Option Explicit

好快的刀，厉害，厉害

mind1238

一把小刀闯天下 发表于 2019-12-18 10:58
刚目测了一下有数据丢失，你统计表中名字边上有空格，源数据表中我倒是给你考虑了，自己修改一下，，，
...

哈哈，是的，我刚刚试了一下，是有丢失，有一个名字好像统计不出来

一把小刀闯天下

mind1238 发表于 2019-12-18 11:02
哈哈，是的，我刚刚试了一下，是有丢失，有一个名字好像统计不出来

2楼修改了一下，你统计表的名字都有缺失，，，

mind1238

Chip_Kenny 发表于 2019-12-18 11:00

都可以用阿，是这样的效果
谢谢，谢谢。太感谢了