分别统计出右边姓名的出现次数，统计的VB语句怎么写？

ssqyc

VB_8列.rar (23.36 KB, 下载次数: 29)

2014-2-14 21:11 上传

点击文件名下载附件

yjh_27

参见附件。

ssqyc

yjh_27 发表于 2014-2-14 22:14
参见附件。

1. Sub test()
   
2.   Set d = CreateObject("scripting.dictionary")
   
3.   Dim r%, ji%
   
4.   r = Cells(Rows.Count, 1).End(xlUp).Row
   
5.   arr = Range("a2:a" & r)
   
6.   For i = 1 To UBound(arr)
   
7.     d(arr(i, 1)) = d(arr(i, 1)) + 1
   
8.   Next
   
9.   kk = d.keys
   
10.   tt = d.items
    
11.   Range("c2:ak" & r).ClearContents
    
12.   For i = 0 To UBound(kk)
    
13.     r = Cells(Rows.Count, tt(i) + 2).End(xlUp).Row + 1
    
14.     Cells(r, tt(i) + 2) = kk(i)
    
15.   Next
    
16. End Sub
    

复制代码

你的速度慢点，这个是单列的，能不能修改成1楼的？？？？？？

yjh_27

清理单元格后，不慢了。

bluexuemei

1. Sub test()
   
2. Dim ojs, i%, j%, arr
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. ojs.eval ("def aa(aa);$aa=aa.flatten!;end")
   
5. [j3:bc65536].Clear
   
6. With Sheet2
   
7.     For i = 1 To 8
   
8.         arr = Range(.Cells(3, i), .Cells(3, i).End(4))
   
9.         y = ojs.Run("aa", arr)
   
10.         For j = 1 To 6
    
11.              brr = ojs.eval("$aa.select{|x|$aa.count(x)==" & j & "}.uniq")
    
12.              If UBound(brr) > -1 Then
    
13.               .Cells(3, 3 + j + 6 * i).Resize(UBound(brr) + 1) = Application.Transpose(brr)
    
14.              End If
    
15.         Next j
    
16.     Next i
    
17. End With
    
18. Set ojs = Nothing
    
19. Stop
    
20. End Sub

复制代码