[已解决]求高手，用VBA怎么实现这样的功能？相信一定会有好心的高手帮忙。

excelers

单元格里面的数字是有由若干（个数不确定，变动的）个01到11的数字组成，怎么样能统计01到11这11个数字在单元格里面各出现的次数（可能是0次），然后将出现次数第最多，第二多，最少，第二少的数字显示出来。并判断得出的号码里面有没有包含特定的那个数字，如果包含了，将该单元格的底纹设置为红色。

最佳答案

月排行榜 / 总排行榜

suye1010

2012-11-8 20:51

1. Sub FindNo()
   
2. Cells.Interior.ColorIndex = 0
   
3. Dim d, i%, j%, T%, arr
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For i = 1 To 11
   
6.    T = (Len(Cells(3, 6)) - Len(Replace(Cells(3, 6), Format(i, "00"), ""))) \ 2
   
7.    If d.exists(T) Then
   
8.         d(T) = d(T) & "," & Format(i, "00")
   
9.    Else
   
10.         d.Add T, Format(i, "00")
    
11.    End If
    
12. Next i
    
13. Cells(3, 7) = Application.WorksheetFunction.Large(d.keys, 1)
    
14. Cells(3, 8) = d(Cells(3, 7).Value)
    
15. If InStr(Cells(3, 8), Cells(3, 3)) Then Cells(3, 8).Interior.ColorIndex = 3
    
16. Cells(3, 9) = Application.WorksheetFunction.Large(d.keys, 2)
    
17. Cells(3, 10) = d(Cells(3, 9).Value)
    
18. If InStr(Cells(3, 10), Cells(3, 3)) Then Cells(3, 10).Interior.ColorIndex = 3
    
19. End Sub
    

复制代码

提供一个思路……剩下的自己组织吧

跳转到最佳答案楼层

兰色幻想

做一个样表传上来吧

excelers

兰色幻想 发表于 2012-11-8 18:36
做一个样表传上来吧

记得传了一个附件的。

suye1010

1. Sub FindNo()
   
2. Cells.Interior.ColorIndex = 0
   
3. Dim d, i%, j%, T%, arr
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. For i = 1 To 11
   
6.    T = (Len(Cells(3, 6)) - Len(Replace(Cells(3, 6), Format(i, "00"), ""))) \ 2
   
7.    If d.exists(T) Then
   
8.         d(T) = d(T) & "," & Format(i, "00")
   
9.    Else
   
10.         d.Add T, Format(i, "00")
    
11.    End If
    
12. Next i
    
13. Cells(3, 7) = Application.WorksheetFunction.Large(d.keys, 1)
    
14. Cells(3, 8) = d(Cells(3, 7).Value)
    
15. If InStr(Cells(3, 8), Cells(3, 3)) Then Cells(3, 8).Interior.ColorIndex = 3
    
16. Cells(3, 9) = Application.WorksheetFunction.Large(d.keys, 2)
    
17. Cells(3, 10) = d(Cells(3, 9).Value)
    
18. If InStr(Cells(3, 10), Cells(3, 3)) Then Cells(3, 10).Interior.ColorIndex = 3
    
19. End Sub
    

复制代码

提供一个思路……剩下的自己组织吧

excelers

suye1010 发表于 2012-11-8 20:51
提供一个思路……剩下的自己组织吧

我蒙了一下large的反义词small，好像是可以。

谢谢。

excelers

suye1010 发表于 2012-11-8 20:51
提供一个思路……剩下的自己组织吧

当数据为空的时候，求大值会报错。可以怎么修改吗？

excelers

suye1010 发表于 2012-11-8 20:51
提供一个思路……剩下的自己组织吧

非常谢谢。在您的引导下，我瞎蒙出了需要的效果。


Cells.Interior.ColorIndex = 0
Dim d, b, i%, j%, T%, arr
Set d = CreateObject("Scripting.Dictionary")
Set b = CreateObject("Scripting.Dictionary")
For i = 1 To 11
   T = (Len(Cells(3, 6)) - Len(Replace(Cells(3, 6), Format(i, "00"), ""))) \ 2
   If d.exists(T) Then
        d(T) = d(T) & "," & Format(i, "00")
   Else
        d.Add T, Format(i, "00")
   End If
Next i
If Cells(3, 6).Value <> "" Then
Cells(3, 7) = Application.WorksheetFunction.Large(d.keys, 1)
Cells(3, 8) = d(Cells(3, 7).Value)
If InStr(Cells(3, 8), Cells(3, 3)) Then Cells(3, 8).Interior.ColorIndex = 3
Cells(3, 9) = Application.WorksheetFunction.Large(d.keys, 2)
Cells(3, 10) = d(Cells(3, 9).Value)
If InStr(Cells(3, 10), Cells(3, 3)) Then Cells(3, 10).Interior.ColorIndex = 3
Else
Cells(3, 7).Value = "空"
Cells(3, 8).Value = "空"
Cells(3, 9).Value = "空"
Cells(3, 10).Value = "空"
End If

For i = 1 To 11
   T = (Len(Cells(6, 6)) - Len(Replace(Cells(6, 6), Format(i, "00"), ""))) \ 2
   If b.exists(T) Then
        b(T) = b(T) & "," & Format(i, "00")
   Else
        b.Add T, Format(i, "00")
   End If
Next i
If Cells(6, 6).Value <> "" Then
Cells(6, 7) = Application.WorksheetFunction.Small(b.keys, 1)
Cells(6, 8) = b(Cells(6, 7).Value)
If InStr(Cells(6, 8), Cells(3, 3)) Then Cells(6, 8).Interior.ColorIndex = 3
Cells(6, 9) = Application.WorksheetFunction.Small(b.keys, 2)
Cells(6, 10) = b(Cells(6, 9).Value)
If InStr(Cells(6, 10), Cells(3, 3)) Then Cells(6, 10).Interior.ColorIndex = 3
Else
Cells(6, 7).Value = "空"
Cells(6, 8).Value = "空"
Cells(6, 9).Value = "空"
Cells(6, 10).Value = "空"
End If