[已解决]多区域统计个数的VBA.

mate66

grf1973 发表于 2017-8-14 15:47
比如任意点一个单元格G15，运行代码，则与G15偏移的多个区域统计。
又任意点一个单元格M17，运行代码，则 ...

再顶下看看

grf1973

1. Sub main()
   
2.     Dim rng As Range, RngColor As Range
   
3.     Set rng = Range("g15")   '自选单元格改为：set rng=selection
   
4.     mycolor = Array(0, 3, 33, 10, 6)    '颜色出现的次序，从第二个开始。
   
5.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
6.     rng.Interior.ColorIndex = 6
   
7.     Range("b35:ar1000") = ""
   
8.     For k = 1 To 4
   
9.         If k = 1 Then
   
10.             Set RngColor = rng.Offset(10, 3).Resize(5, 12)
    
11.         ElseIf k = 2 Then
    
12.             Set RngColor = rng.Offset(3, 3).Resize(4, 12)
    
13.         ElseIf k = 3 Then
    
14.             Set RngColor = rng.Offset(-3, 13).Resize(5, 18)
    
15.         Else
    
16.             Set RngColor = rng.Offset(4, 21).Resize(5, 14)
    
17.         End If
    
18.         RngColor.Interior.ColorIndex = mycolor(k)
    
19.         c = RngColor.Column
    
20.         rmax = Cells(65536, c).End(3).Row + 2
    
21.         Cells(rmax, c).Resize(10, 2) = 统计个数(RngColor)
    
22.         Cells(rmax, c).Resize(10, 2).Interior.ColorIndex = mycolor(k)
    
23.     Next
    
24. End Sub
    
25. Function 统计个数(rng As Range)
    
26.     Dim arr(9, 1 To 2), x As Range
    
27.     For Each x In rng
    
28.         y = x.Value
    
29.         arr(x, 1) = x
    
30.         arr(x, 2) = arr(x, 2) + 1
    
31.     Next
    
32.     For i = 0 To 8
    
33.         For j = i + 1 To 9
    
34.             If arr(j, 2) > arr(i, 2) Then
    
35.                 tmp = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = tmp
    
36.                 tmp = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = tmp
    
37.             End If
    
38.         Next
    
39.     Next
    
40.     统计个数 = arr
    
41. End Function

复制代码

grf1973

还可以事先把偏移量用数组记录下来，循环调用数组即可

1. Sub main()
   
2.     Dim rng As Range, RngColor As Range
   
3.     Set rng = Range("g15")   '自选单元格改为：set rng=selection
   
4.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
5.     rng.Interior.ColorIndex = 6
   
6.     Range("b35:ar1000") = ""
   
7.     xrr = [{10,3,5,12;3,3,4,12;-3,13,5,18;4,21,5,14}]   '每次的偏移量
   
8.     mycolor = Array(0, 3, 33, 10, 6)    '颜色出现的次序，从第二个开始。
   
9.     For k = 1 To UBound(xrr)
   
10.         Set RngColor = rng.Offset(xrr(k, 1), xrr(k, 2)).Resize(xrr(k, 3), xrr(k, 4))
    
11.         RngColor.Interior.ColorIndex = mycolor(k)
    
12.         c = RngColor.Column
    
13.         rmax = Cells(65536, c).End(3).Row + 2
    
14.         Cells(rmax, c).Resize(10, 2) = 统计个数(RngColor)
    
15.         Cells(rmax, c).Resize(10, 2).Interior.ColorIndex = mycolor(k)
    
16.     Next
    
17. End Sub
    
18. Function 统计个数(rng As Range)
    
19.     Dim arr(9, 1 To 2), x As Range
    
20.     For Each x In rng
    
21.         y = x.Value
    
22.         arr(x, 1) = x
    
23.         arr(x, 2) = arr(x, 2) + 1
    
24.     Next
    
25.     For i = 0 To 8
    
26.         For j = i + 1 To 9
    
27.             If arr(j, 2) > arr(i, 2) Then
    
28.                 tmp = arr(i, 2): arr(i, 2) = arr(j, 2): arr(j, 2) = tmp
    
29.                 tmp = arr(i, 1): arr(i, 1) = arr(j, 1): arr(j, 1) = tmp
    
30.             End If
    
31.         Next
    
32.     Next
    
33.     统计个数 = arr
    
34. End Function

复制代码

grf1973

主程序还可简化一点，把偏移量和颜色放到一个数组里。。。。

1. Sub main()
   
2.     Dim rng As Range, RngColor As Range
   
3.     Set rng = Range("g15")   '自选单元格改为：set rng=selection
   
4.     ActiveSheet.UsedRange.Cells.Interior.ColorIndex = 0
   
5.     rng.Interior.ColorIndex = 6
   
6.     Range("b35:ar1000") = ""
   
7.     xrr = [{10,3,5,12,3;3,3,4,12,33;-3,13,5,18,10;4,21,5,14,6}]   '每次的偏移量及颜色
   
8.     For k = 1 To UBound(xrr)
   
9.         Set RngColor = rng.Offset(xrr(k, 1), xrr(k, 2)).Resize(xrr(k, 3), xrr(k, 4))
   
10.         RngColor.Interior.ColorIndex = xrr(k, 5)
    
11.         c = RngColor.Column
    
12.         rmax = Cells(65536, c).End(3).Row + 2
    
13.         Cells(rmax, c).Resize(10, 2) = 统计个数(RngColor)
    
14.         Cells(rmax, c).Resize(10, 2).Interior.ColorIndex = xrr(k, 5)
    
15.     Next
    
16. End Sub

复制代码

mate66

grf1973 发表于 2017-8-15 11:12
主程序还可简化一点，把偏移量和颜色放到一个数组里。。。。

这是顶级的顶级的顶级的高手。谢谢！

02761752696

grf1973 发表于 2017-8-15 11:12
主程序还可简化一点，把偏移量和颜色放到一个数组里。。。。

学习了  谢谢