Hsieh

回復 19# cmo140497

1. Sub Get_Rng()
   
2. Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
   
3. With ActiveSheet
   
4. For Each Sp In .Shapes
   
5. If Sp.Name Like "Check Box*" Then
   
6. If Sp.OLEFormat.Object.Value = 1 Then
   
7. n = Sp.OLEFormat.Object.Caption
   
8. Set A = .Columns("E").Find(n, lookat:=xlWhole)
   
9. If Rng Is Nothing Then
   
10.     Set Rng = A.CurrentRegion
    
11.     Else
    
12.     Set Rng = Union(Rng, A.CurrentRegion)
    
13. End If
    
14. End If
    
15. End If
    
16. Next
    
17. If Rng Is Nothing Then
    
18. MsgBox "Nothing"
    
19. Else
    
20. For x = 1 To Rng.Areas(1).Columns.Count
    
21.    For y = 2 To Rng.Areas(1).Rows.Count
    
22.    ReDim ay(1 To Rng.Areas.Count)
    
23.    ReDim ary(1 To Rng.Areas.Count)
    
24.       For i = 1 To Rng.Areas.Count
    
25.          ay(i) = Rng.Areas(i).Cells(y, x)
    
26.          If Rng.Areas(i).Cells(y, x) = "000" Then zero = zero + 1
    
27.       Next
    
28.       For j = 1 To UBound(ay)
    
29.          For s = 1 To UBound(ay)
    
30.            If ay(j) = ay(s) Then cnt = cnt + 1
    
31.          Next
    
32.          ary(j) = cnt: cnt = 0
    
33.       Next
    
34.       g = Application.Lookup(Application.Max(ary) / Rng.Areas.Count, Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1), Array(4, 44, 8, 6, 7, 3, 16))
    
35.       With .[AI2].CurrentRegion.Cells(y - 1, x)
    
36.       If .Value = "___" Then
    
37.          .Interior.ColorIndex = -4142
    
38.          ElseIf zero = Rng.Areas.Count Then '全部都是000
    
39.          .Interior.ColorIndex = 4
    
40.          Else
    
41.          .Interior.ColorIndex = g
    
42.        End If
    
43.        zero = 0
    
44.        End With
    
45. 10
    
46.     Next
    
47. Next
    
48. End If
    
49. End With
    
50. End Sub

複製代碼

GBKEE

16# 檔案的程式碼,試看看程式處裡的速度是否滿意!!

1. Option Explicit
   
2. Const xRow As Integer = 24
   
3. Const xCol As Integer = 24
   
4. Private Sub AUTO_OPEN()
   
5.     Dim Rng As Range, E As Range, xi As Integer
   
6.     Sheets("Overlap").Activate
   
7.     Set Rng = [A:A]
   
8.     Rng.Replace "ID", "=XXX", xlWhole
   
9.     Set Rng = Rng.SpecialCells(xlCellTypeFormulas, xlErrors)
   
10.     ActiveSheet.CheckBoxes.Delete
    
11.     For Each E In Rng.Cells
    
12.         With Cells(xi + 5, "AA")
    
13.             With ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
    
14.                 .Caption = "Item" & xi + 1
    
15.                 .OnAction = "Ex_Action"
    
16.                 E.Offset(1, 1).Resize(xRow, xCol).Name = "_" & .Caption  '設置範圍名稱
    
17.             End With
    
18.         End With
    
19.         xi = xi + 1
    
20.     Next
    
21.     Rng.Value = "ID"
    
22. End Sub
    
23. Private Sub Ex_Action()
    
24.     Dim cBox As Object, Rng As Range, r As Integer, y As Integer, xi As Integer
    
25.     Dim Ar(), E As Variant, t As Date
    
26.     t = Time
    
27.     For Each cBox In ActiveSheet.CheckBoxes
    
28.         If cBox.Value = 1 Then
    
29.             If Rng Is Nothing Then Set Rng = Range("_" & cBox.Caption)
    
30.             If Not Rng Is Nothing Then Set Rng = Union(Rng, Range("_" & cBox.Caption))
    
31.         End If
    
32.     Next
    
33.     With Range("AI5").Resize(xRow, xCol)
    
34.         .Interior.ColorIndex = xlNone
    
35.         For Each cBox In .Cells
    
36.             If cBox <> "___" Then cBox = 0
    
37.         Next
    
38.     End With
    
39.     Application.ScreenUpdating = False
    
40.     Range("B:Z").Interior.ColorIndex = xlNone
    
41.     If Rng Is Nothing Then Exit Sub
    
42.     ReDim Ar(1 To xRow, 1 To xCol)                                      '設定:陣列大小
    
43.     '********  每一個範圍中同一位置有資料的:計數
    
44.     For Each cBox In Rng.Areas                                          '處裡每一個範圍
    
45.         For r = 1 To xRow
    
46.             For y = 1 To xCol
    
47.                 If cBox(r, y) = "___" Then GoTo 0                       '不處裡
    
48.                 If cBox(r, y) <> 0 Then Ar(r, y) = Ar(r, y) + 1         '紀錄資料
    
49. 0:
    
50.             Next
    
51.         Next
    
52.     Next
    
53.     '********  每一個範圍中同一位置資料的計數百分比:設下顏色
    
54.     For Each cBox In Rng.Areas
    
55.         For r = 1 To xRow
    
56.             For y = 1 To xCol
    
57.                 xi = 0                                                  '百分比:歸零
    
58.                 If cBox(r, y) = "___" Then GoTo 1
    
59.                 For Each E In Array(0, 0.19, 0.39, 0.59, 0.79, 0.99, 1)
    
60.                     xi = xi + 1
    
61.                     If Ar(r, y) / Rng.Areas.Count <= E Then Exit For    '取得百分比
    
62.                 Next
    
63.                 If Ar(r, y) > 0 Then cBox(r, y).Interior.ColorIndex = [AA2].Cells(1, xi).Interior.ColorIndex
    
64.                                                                         '[AA2].Cells(1, xi):顏色的位置
    
65. 1:
    
66.             Next
    
67.         Next
    
68.     Next
    
69.     '********  統計範圍位置資料: 計數, 百分比顏色
    
70.     With Range("AI5")
    
71.         For r = 1 To xRow
    
72.             For y = 1 To xCol
    
73.                 If .Cells(r, y) <> "___" Then
    
74.                     .Cells(r, y) = IIf(Ar(r, y) = "", 0, Ar(r, y))
    
75.                     If Ar(r, y) > 0 Then
    
76.                     .Cells(r, y).Interior.ColorIndex = Rng(r, y).Interior.ColorIndex
    
77.                     Else
    
78.                     .Cells(r, y).Interior.ColorIndex = [AA2].Interior.ColorIndex
    
79.                     End If
    
80.                 End If
    
81.             Next
    
82.         Next
    
83.     End With
    
84.     Application.ScreenUpdating = True
    
85.     MsgBox Format(t, "開始 hh:mm:ss") & vbLf & Format(Time, "結束 hh:mm:ss") & vbLf & vbLf & Format(Time - t, "費時 hh:mm:ss")
    
86. End Sub

複製代碼

回復 19# cmo140497

cmo140497

回復 22# GBKEE

Dear GBKEE 版主 :
實在不好意思啦,並不是有意的,真的很感謝版主及在這裡的高手們替小弟解決困擾,小弟也會從這些發問中學到不少應用,真的很感謝版主您的幫忙,感恩!

cmo140497

回復 21# Hsieh


    再度感謝版主,實在感恩,謝謝!