[已解决]求个统计个数的vba

zhaongxa

Book2.xls22.rar (6.48 KB, 下载次数: 11)

2012-3-15 09:33 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hrpotter

2012-3-15 10:14

1. Sub 提取()
   
2.     Dim d As New Dictionary
   
3.     Dim i As Integer, j As Integer, k As Integer, l As Integer
   
4.     Dim ar, br(1 To 1000, 1 To 2)
   
5.     ar = Range("d6:iq15")
   
6.     For i = 1 To UBound(ar)
   
7.         For j = 1 To UBound(ar, 2)
   
8.             d(ar(i, j)) = d(ar(i, j)) + 1
   
9.         Next j
   
10.         For k = 1 To d.Count
    
11.             If d.Items(k - 1) < 18 Or d.Items(k - 1) > 45 Then
    
12.                 l = l + 1
    
13.                 br(l, 1) = d.Items(k - 1) & "个"
    
14.                 br(l, 2) = d.Keys(k - 1)
    
15.             End If
    
16.         Next k
    
17.         d.RemoveAll
    
18.     Next
    
19.     Range("a2:b65536").ClearContents
    
20.     If l > 0 Then
    
21.         Range("a2").Resize(l, 2) = br
    
22.     End If
    
23. End Sub

复制代码

运行前，工具-引用-浏览-文件名输入scrrun.dll,打开-确定

跳转到最佳答案楼层

sliang28

小题
不过没有黄色，只有绿色区域
意思没有说清楚：如果满足条件的有两个或者以上，结果应该在那里显示?

zhaongxa

sliang28 发表于 2012-3-15 09:40
小题
不过没有黄色，只有绿色区域

是的写错了,太大意了是绿色

sliang28

zhaongxa 发表于 2012-3-15 09:46
是的写错了,太大意了是绿色

刚刚又重新编辑了一下我的疑问，你看看。问清楚再写，要不写出来的是我的意思，不是你的意思？

hrpotter

1. Sub 提取()
   
2.     Dim d As New Dictionary
   
3.     Dim i As Integer, j As Integer, k As Integer, l As Integer
   
4.     Dim ar, br(1 To 1000, 1 To 2)
   
5.     ar = Range("d6:iq15")
   
6.     For i = 1 To UBound(ar)
   
7.         For j = 1 To UBound(ar, 2)
   
8.             d(ar(i, j)) = d(ar(i, j)) + 1
   
9.         Next j
   
10.         For k = 1 To d.Count
    
11.             If d.Items(k - 1) < 18 Or d.Items(k - 1) > 45 Then
    
12.                 l = l + 1
    
13.                 br(l, 1) = d.Items(k - 1) & "个"
    
14.                 br(l, 2) = d.Keys(k - 1)
    
15.             End If
    
16.         Next k
    
17.         d.RemoveAll
    
18.     Next
    
19.     Range("a2:b65536").ClearContents
    
20.     If l > 0 Then
    
21.         Range("a2").Resize(l, 2) = br
    
22.     End If
    
23. End Sub

复制代码

运行前，工具-引用-浏览-文件名输入scrrun.dll,打开-确定