Board logo

標題: [發問] 如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定 [打印本頁]
作者: cmo140497    時間: 2012-12-16 22:09     標題: 如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定

本帖最後由 GBKEE 於 2012-12-17 15:51 編輯

Dear 各位版主或高手大大們 :
  小弟先前請教過各位版主及大大的一些巨集的問題,也感謝各位的不吝指教,今有一個問題,已經煩了快一個月,已遍歷國外各大網站vba或函數的例子,仍無法解決困擾已久的問題
希望可以從各位版主或高手大大們尋得協助,謝謝!
以下介紹幾個網站還滿不錯的:
http://www.get-digital-help.com/category/excel/table/
http://chandoo.org/wp/2009/03/25/using-array-formulas-example1/
http://www.contextures.com/tiptech.html

小弟想依指定路徑下之資料夾找到資料夾內之檔案,作自動新增核取方塊數量,如以下圖片有3個文字檔內容已被小弟載入excel內,要如何比較各筆之相同位址之資料,是否重覆?如有
重覆並計算重覆次數除以核定片數,作百分比之格式化條件的顏色分類,如下圖所示

[attach]13552[/attach]

[attach]13553[/attach]
作者: Hsieh    時間: 2012-12-16 23:47

回復 1# cmo140497
試試看
  1. Sub AddCheckBox() '加入核取方塊
  2. '因為沒有提供文字檔，以現有Item作為新增條件
  3. With Sheet1
  4. .CheckBoxes.Delete
  5. k = Application.CountIf(.Columns("E"), "ID")
  6. Set A = .Columns("F").Find("Item", lookat:=xlPart)
  7. For i = 1 To k
  8.   With .CheckBoxes.Add(.Cells(i + 4, "C").Left, .Cells(i + 4, "C").Top, .Cells(i + 4, "C").Width, .Cells(i + 4, "C").Height)
  9.      .Characters.Text = A
  10.   End With
  11.   Set A = .Columns("F").FindNext(A)
  12. Next
  13. End With
  14. End Sub
  15. Sub 比對()
  16. Dim Sp As Shape, Rng As Range, A As Range, MyRng As Range
  17. With Sheet1
  18.    For Each Sp In .Shapes
  19.      If Sp.Name Like "Check Box*" Then
  20.      Set A = .Columns("F").Find(Sp.OLEFormat.Object.Caption)
  21.       If Sp.OLEFormat.Object.Value = 1 Then
  22.       If Rng Is Nothing Then
  23.          Set Rng = A.Offset(1, 0).Resize(5, 5)
  24.          Else
  25.          Set Rng = Union(Rng, A.Offset(1, 0).Resize(5, 5))
  26.        End If
  27.        End If
  28.      End If
  29.     Next
  30.     Set MyRng = .[M3:Q7]
  31. If Not Rng Is Nothing Then
  32.   For i = 1 To 5
  33.      For j = 1 To 5
  34.      If MyRng(i, j) <> 0 And MyRng(i, j) <> "___" Then
  35.        For Each ar In Rng.Areas
  36.          If ar(i, j) = MyRng(i, j) Then p = p + 1
  37.        Next
  38.        s = p / Rng.Areas.Count: p = 0
  39.        n = Application.Lookup(s, Array(0, 0.1, 0.2, 0.4, 0.6, 0.8, 1), Array(1, 2, 3, 4, 5, 6, 7))
  40.        MyRng.Cells(i, j).Interior.ColorIndex = .[S2:Y2].Cells(1, n).Interior.ColorIndex
  41.        Else
  42.        MyRng.Cells(i, j).Interior.ColorIndex = -4142
  43.     End If
  44.      Next
  45.   Next
  46. End If
  47. End With
  48. End Sub
複製代碼
作者: cmo140497    時間: 2012-12-17 09:12

回復 2# Hsieh


    實在大大的感謝Hsieh 超級版主的頂力協助,請問版主您大概寫這個程式花了多少時間,小弟昨晚po的,才剛上班打開電腦就收到回覆了,實在令小弟有點....:'(

另還有一個問題想請教版主,關於底下這行,這陣列是小弟自己用算的,請問要如何自行做陣列之運算(比較/合併),將有重覆或獨立值代至新的陣列內,仍繼續做條件格式化百分比,
Set MyRng = .[M3:Q7]
因為這陣列有可能x/y會有20~50之多,如果可以自行比較出結果的話.....再度感謝版主不辭辛苦的解決新手小弟的困擾,實在感恩!
作者: Hsieh    時間: 2012-12-17 09:19

回復  Hsieh


    實在大大的感謝Hsieh 超級版主的頂力協助,請問版主您大概寫這個程式花了多少時間,小 ...
cmo140497 發表於 2012-12-17 09:12


用多少時間並不重要，是否達到需求才是重點
至於MyRng是要比對改變顏色的區域
至於你要多個範圍就看你的表格分佈規則而定
上傳檔案試試看吧
作者: cmo140497    時間: 2012-12-17 09:31

回復 2# Hsieh


    不好意思,版主再度打擾您,剛才忘記附上文字檔.
如果各陣列位址的值均不相同,則視為100%,代碼7的顏色,不知是否可行,感謝您。


[attach]13555[/attach]
作者: cmo140497    時間: 2012-12-17 09:47

回復 4# Hsieh


    不好意思,小弟沒來得及看回覆,又丟了疑問給您,實在抱歉.
小弟的陣列均為二維,行列數有時可能會多達20更甚多,內容只有固定之數值F00~F150,沒有其它數值或文字,只是陣列數須依實際檔案數而定,要篩選或比對則由人自行決定,
資料附檔如下附件,請參考,再度感謝,謝謝!

[attach]13556[/attach]
作者: Hsieh    時間: 2012-12-17 10:32

回復 6# cmo140497


   這樣已經錯亂了，請說明你的整體流程
所附的txt檔案是要寫入E:J欄位或是要放到M:Q欄作為比對變色儲存格?
這些文字檔資料所形成的陣列欄、列數可能是不同的，那麼顏色對照表[S2:Y2]的位置是否又要改變?
作者: cmo140497    時間: 2012-12-17 13:34

回復 7# Hsieh

不好意思,小弟再整理一下流程,再麻煩版主您再幫小弟看一下,再度打擾您了,謝謝!

    [attach]13575[/attach]


[attach]13576[/attach]
作者: GBKEE    時間: 2012-12-17 15:42

回復 8# cmo140497
AUTO_OPEN() 檔案開啟時自動執行
  1. Option Explicit
  2. Sub AUTO_OPEN() '加入核取方塊'因為沒有提供文字檔，以現有Item作為新增條件
  3.     Dim A As Range, K As Integer, i As Integer
  4.     With Sheet1
  5.         .CheckBoxes.Delete
  6.         .Range("B:Z").Interior.ColorIndex = xlNone
  7.         K = Application.CountIf(.Columns("A"), "ID")
  8.         Set A = .Columns("A").Find("ID", lookat:=xlPart)
  9.         For i = 1 To K
  10.         Cells(i + 5, "AA").Select
  11.             With .CheckBoxes.Add(.Cells(i + 5, "AA").Left, .Cells(i + 5, "AA").Top, .Cells(i + 5, "AA").Width, .Cells(i + 5, "AA").Height)
  12.                 .Characters.Text = "Item" & i
  13.                 .Name = "Item" & i
  14.                 .OnAction = "EX"                              'CheckBoxes 指巨集的 程式
  15.             End With
  16.             A.Offset(1, 1).Resize(24, 24).Name = "_Item" & i  '資料範圍設立名稱:如工作表定義名稱
  17.             Set A = .Columns("A").FindNext(A)
  18.         Next
  19.         '**  製定百分比 為 7 等分 [S1:Y1] 百分比由大到小   ***
  20.         For i = 1 To 7  '百分比由大到小   
  21.             .[AA2].Cells(1, i) = 1 + (1 / 7) - (i / 7)
  22.         Next
  23.     End With
  24. End Sub
  25. Sub EX()   '已執行AUTO_OPEN, 按選CheckBoxes的程式
  26.     Dim Rng(0 To 25) As Range, S, i
  27.     Dim P As Integer, B As CheckBox, E As Variant
  28.     With Sheet1
  29.          .Range("B:Z").Interior.ColorIndex = xlNone
  30.         For Each B In .CheckBoxes
  31.             If B = 1 Then                                               'CheckBoxe；勾選 = 1
  32.                 P = P + 1
  33.                 If Not Rng(0) Is Nothing Then
  34.                     Set Rng(0) = Union(Rng(0), .Range("_" & B.Name))
  35.                     For i = 1 To 24                                     '已勾選範圍之 第1欄-第24欄
  36.                         For Each E In Rng(0).Areas
  37.                             Set Rng(i) = Union(E.Columns(i), Rng(i))    '同一欄位 設為同一範圍
  38.                         Next
  39.                     Next
  40.                 Else
  41.                     Set Rng(0) = .Range("_" & B.Name)
  42.                     For i = 1 To 24
  43.                         Set Rng(i) = Rng(0).Columns(i)
  44.                     Next
  45.                 End If
  46.             End If
  47.         Next
  48.         If P = 0 Then Exit Sub
  49.         Application.ScreenUpdating = False
  50.         For i = 1 To 24                                     '範圍有24欄
  51.             .Columns(Columns.Count - 1) = ""                '清除 最後第2欄資料
  52.             .Columns(Columns.Count) = ""                    '清除 最後1欄資料
  53.             Rng(i).Copy Cells(1, Columns.Count)             '複製欄的資料
  54.             .Columns(Columns.Count).AdvancedFilter xlFilterCopy, .Cells(1, Columns.Count - 1), Unique:=True
  55.             '進階篩選:選取不重複的資料,減少迴圈.
  56.             .Columns(Columns.Count - 1).Sort Key1:=.Cells(1, Columns.Count - 1), Order1:=xlDescending, Header:=xlNo
  57.             '排序 : 不要的資料置於底部
  58.             Set Rng(25) = .Columns(Columns.Count - 1).Cells(1)   '設定要尋找的字串
  59.             
  60.             With Rng(i)
  61.                 Do Until Rng(25) = "___" Or Rng(25) = "0" Or Rng(25) = ""
  62.                     Set Rng(0) = .Find(Rng(25), lookat:=xlWhole)
  63.                     If Not Rng(0) Is Nothing Then
  64.                         .Replace Rng(25), "=xxx", xlWhole               '如同工作表尋找:全部取代 為錯誤的公式
  65.                         .SpecialCells(xlCellTypeFormulas).Select
  66.                         S = Application.CountA(Selection) / P
  67.                        If S <= 1 Then
  68.                             S = Application.Match(S, [AA2:AG2], -1)     'Match 的排序:大到小
  69.                         Else
  70.                             S = 1
  71.                        End If
  72.                         Selection.Value = Rng(25)                       '復原 取代的字串
  73.                         Selection.Interior.ColorIndex = Sheet1.[AA2].Cells(1, S).Interior.ColorIndex
  74.                     End If
  75.                 Set Rng(25) = Rng(25).Offset(1)                         '尋找下一個字串
  76.                 Loop
  77.             End With
  78.         Next
  79.         .Columns(Columns.Count - 1) = ""                '清除 最後第2欄資料
  80.         .Columns(Columns.Count) = ""                    '清除 最後1欄資料
  81.         Application.ScreenUpdating = True
  82.         .CheckBoxes(Application.Caller).TopLeftCell.Select
  83.       End With
  84. End Sub
複製代碼
作者: cmo140497    時間: 2012-12-17 16:18

回復 9# GBKEE


    再度感謝版主幫小弟解決這個困擾已久的問題,不過小弟在試run的時候,出現了一個問題,如下圖示所示,實在不知道如何作troubleshooting,再麻煩版主一下,感恩
[attach]13577[/attach]

[attach]13578[/attach]
作者: GBKEE    時間: 2012-12-17 16:36

本帖最後由 GBKEE 於 2012-12-17 16:45 編輯

回復 10# cmo140497
你的資料顯示是2003版 何不在2003試看
測試12# 2010版 需是
  1. .Columns(Columns.Count).AdvancedFilter xlFilterCopy, , .Cells(1, Columns.Count - 1), Unique:=True
複製代碼
作者: cmo140497    時間: 2012-12-17 16:41

回復 11# GBKEE


    小弟是用office 2010 plus版,再麻煩版主幫小弟看一下,感恩

[attach]13579[/attach]
作者: cmo140497    時間: 2012-12-17 17:01

回復 11# GBKEE


    Dear 版主:
應該是可以了,小弟得花點時間看一下,也希望版主可以不吝指導,另外小弟如果想把Total結果丟在旁邊的位址(AI5:BF28),不知是否可行?及顏色的計算好像反了,及如果均為0,不知是否可呈現代碼1的顏色,不知是否可再行修正?
還是很感謝版主您的大力的協助,感恩!



[attach]13580[/attach]
作者: cmo140497    時間: 2012-12-17 19:22

回復 4# Hsieh


    Dear Hsieh 版主大大:
不好意思,再度打擾您了,關於小弟的問題,不知您是否有更好的作法,從GBKEE版主的作法,執行速度上會有點慢,如果方便的話,小弟將流程更簡化,直接計數不為0之Count,除以核取方塊數,計算百分比條件格式化之顏色代碼,如有您方便的話,再煩請版主您再幫忙一下,感恩!


[attach]13583[/attach]


[attach]13584[/attach]
作者: Hsieh    時間: 2012-12-17 19:42

回復 14# cmo140497
非常抱歉，我實在看不懂你整體流程與所需效果
請教以下問題
1、文字檔的用意是甚麼?
2、要變色的位置到底是哪個位置?
3、要變色的位置的資料是如何取得?
4、請盡可能將您的所有動作流程敘述清楚
要用檔案解釋您的問題，請用一致的檔案
作者: cmo140497    時間: 2012-12-18 14:57

回復 15# Hsieh


    Dear Hsieh 版主 :
    實在不好意思,造成您的困擾,希望您可見諒..關於您的疑問
1、文字檔的用意是甚麼?
       這文字檔代表一個產品的檢查結果,小弟想知道它與其它間有沒有集中或重疊的趨勢,藉以了解並試找出可能是哪一個流程出問題
2、要變色的位置到底是哪個位置?
      希望是可以在固定位置Range("AI5:BF28"),而不是每個文字檔的位置,不好意思,小弟沒有說明清楚,抱歉
3、要變色的位置的資料是如何取得?
      所以小弟變更流程,三個ID相同位址只要有<>0,則計算1,三個都<>0,則計算3,將3除以核取方塊勾選的片數3=100%,則以100%之顏色
      填入要變色的位置即可,毋需再用文字檔之資料與要變色之資料作比對了,不知這樣是否可行?
4、請盡可能將您的所有動作流程敘述清楚
    不好意思,因為上班用公司電腦,有點Lag,上傳資料有時怪怪的,造成您的困擾,實在抱歉

希望版主再幫忙看一下,感恩,謝謝!


[attach]13594[/attach]
作者: Hsieh    時間: 2012-12-19 01:01

回復 16# cmo140497
不知道理解是否正確
將文字檔與程式檔至於同一資料夾試試
[attach]13602[/attach]
  1. Sub InputData()
  2. Dim Btn(), Mystr$, ARng As Range
  3. fd = ThisWorkbook.Path & "\"
  4. fs = Dir(fd & "*.txt")
  5. With ActiveSheet
  6. .CheckBoxes.Delete
  7. .Cells.Clear
  8. Do Until fs = ""
  9. Open fd & fs For Input As #1
  10.    Do While Not EOF(1)
  11.      Line Input #1, Mystr
  12.      If InStr(Mystr, ":") > 0 Then
  13.      r = r + 1
  14.        .Cells(r, 3) = Split(Mystr, ":")(0)
  15.         If InStr(Split(Mystr, ":")(1), " ") > 0 Then
  16.            ar = Split(Split(Mystr, ":")(1), " ")
  17.            .Cells(r, 5).Resize(, UBound(ar) + 1) = ar
  18.         Else
  19.            .Cells(r, 5) = Replace(Split(Mystr, ":")(1), "ITEM", "")
  20.            ReDim Preserve Btn(s)
  21.            Btn(s) = Replace(Split(Mystr, ":")(1), "ITEM", "")
  22.            s = s + 1
  23.         End If
  24.      End If
  25.     Loop
  26. Close #1
  27. r = r + 1
  28.     fs = Dir
  29. Loop
  30. .Cells(r, 5).Resize(, UBound(ar) + 1).EntireColumn.AutoFit
  31. For i = 0 To s - 1
  32.   With .CheckBoxes.Add(.Cells(i + 4, "A").Left, .Cells(i + 4, "A").Top, .Cells(i + 4, "A").Width, .Cells(i + 4, "A").Height)
  33.      .Characters.Text = Btn(i)
  34.      .OnAction = "Get_Rng"
  35.   End With
  36. Next
  37. .Range(.Range(.[E2], .[E2].End(xlDown)), .Range(.[E2], .[E2].End(xlDown)).End(xlToRight)).Copy .[AI2]
  38. .[AI2].CurrentRegion.EntireColumn.AutoFit
  39. Set ARng = .[AI2].CurrentRegion
  40. ARng.Replace "___", ""
  41. ARng.SpecialCells(xlCellTypeConstants).Value = 0
  42. ARng.SpecialCells(xlCellTypeBlanks).Value = "___"
  43. End With
  44. ActiveWindow.Zoom = 75
  45. End Sub
  46. Sub Get_Rng()
  47. Dim A As Range, Rng As Range, Sp As Shape, CRng As Range
  48. With ActiveSheet
  49. For Each Sp In .Shapes
  50. If Sp.Name Like "Check Box*" Then
  51. If Sp.OLEFormat.Object.Value = 1 Then
  52. n = Sp.OLEFormat.Object.Caption
  53. Set A = .Columns("E").Find(n, lookat:=xlWhole)
  54. If Rng Is Nothing Then
  55.     Set Rng = A.CurrentRegion
  56.     Else
  57.     Set Rng = Union(Rng, A.CurrentRegion)
  58. End If
  59. End If
  60. End If
  61. Next
  62. If Rng Is Nothing Then
  63. MsgBox "Nothing"
  64. Else
  65. For x = 1 To Rng.Areas(1).Columns.Count
  66.    For y = 2 To Rng.Areas(1).Rows.Count
  67.    ReDim ay(1 To Rng.Areas.Count)
  68.    ReDim ary(1 To Rng.Areas.Count)
  69.       For i = 1 To Rng.Areas.Count
  70.       If Rng.Areas(i).Cells(y, x) = "000" Then .[AI2].CurrentRegion.Cells(y - 1, x).Interior.ColorIndex = 4: GoTo 10
  71.          ay(i) = Rng.Areas(i).Cells(y, x)
  72.       Next
  73.       For j = 1 To UBound(ay)
  74.          For s = 1 To UBound(ay)
  75.            If ay(j) = ay(s) Then cnt = cnt + 1
  76.          Next
  77.          ary(j) = cnt: cnt = 0
  78.       Next
  79.       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))
  80.       With .[AI2].CurrentRegion.Cells(y - 1, x)
  81.       If .Value = "___" Then
  82.          .Interior.ColorIndex = -4142
  83.          Else
  84.          .Interior.ColorIndex = g
  85.        End If
  86.        End With
  87. 10
  88.     Next
  89. Next
  90. End If
  91. End With
  92. End Sub
複製代碼
作者: cmo140497    時間: 2012-12-19 14:32     標題: (已解決)如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定

回復 17# Hsieh

感謝版主不吝指教,這樣看起來真的簡單多了,對於您的大恩大德,小弟畢生難忘,太感謝您了,謝謝!
作者: cmo140497    時間: 2012-12-19 16:17

回復 17# Hsieh


    Dear Hsieh版主 :
    不好意思,再度打擾您一下,感謝版主您提供協助,小弟測試了一下,有點小小的bug,不知您是否可以再幫小弟debug一下,主要在相除母數,似乎把右列僅欲顯示的圖值,加進來了,變成任何值與0比較,均變為0,感恩


[attach]13611[/attach]
作者: davidju041206    時間: 2012-12-19 19:49

雖無權限下載...仍謝謝您的分享...
努力增加等級中...
作者: Hsieh    時間: 2012-12-19 23:33

回復 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    時間: 2012-12-20 09:34

本帖最後由 GBKEE 於 2012-12-20 09:44 編輯

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    時間: 2012-12-21 08:08

回復 22# GBKEE

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

回復 21# Hsieh


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)