如何求出每个人的问题数量，谢谢

松永

如何汇总出每个人的问题数量，数量比较多，最好用动态的，谢谢。

松永

附件发出。谢谢。

ww87725244

1. Sub aa()
   
2. Dim ar, i, k, s, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     ar = .Range("a1").CurrentRegion
   
6.     For i = 2 To UBound(ar)
   
7.         For k = 2 To UBound(ar, 2)
   
8.             If ar(i, k) <> "" Then
   
9.                 If Not d.exists(ar(i, 1)) Then
   
10.                     s = 1
    
11.                     d(ar(i, 1)) = s
    
12.                 Else
    
13.                     d(ar(i, 1)) = d(ar(i, 1)) + 1
    
14.                 End If
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     .[h1].Resize(d.Count) = Application.Transpose(d.keys)
    
19.     .[i1].Resize(d.Count) = Application.Transpose(d.items)
    
20. End With
    
21. Set d = Nothing
    
22. End Sub

复制代码

ykcbf1100

字典统计

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.2
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = [a1].Resize(r, 6)
   
5.     ReDim brr(1 To r, 1 To 2)
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 1)
   
8.         If Not d.exists(s) Then
   
9.             m = m + 1
   
10.             d(s) = m
    
11.             brr(m, 1) = s
    
12.             Sum = 0
    
13.             For j = 2 To UBound(arr, 2)
    
14.                 If Val(arr(i, j)) Then Sum = Sum + 1
    
15.             Next
    
16.             brr(m, 2) = Sum
    
17.         Else
    
18.             r = d(s)
    
19.             Sum = 0
    
20.             For j = 2 To UBound(arr, 2)
    
21.                 If arr(i, j) <> Empty Then Sum = Sum + 1
    
22.             Next
    
23.             brr(r, 2) = brr(r, 2) + Sum
    
24.         End If
    
25.     Next
    
26.     [o3:p1000] = ""
    
27.     [o3].Resize(m, 2) = brr
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码

680926

Sub t()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim arr
arr = Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        If arr(i, j) <> "" Then
            d(arr(i, 1)) = d(arr(i, 1)) + 1
        End If
    Next
Next
[s3].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

无关岁月

如何用求出每个人的问题数量.7z (15.98 KB, 下载次数: 1)

2024-8-2 16:46 上传

点击文件名下载附件

小凡、、、

自定义函数，同理字典去重计数

松永

ww87725244 发表于 2024-8-2 16:04

谢谢老师指导

松永

ykcbf1100 发表于 2024-8-2 16:23
字典统计

谢谢老师多次帮助