[發問] 如何使用VBA或函數做多個陣列數值的比較及格式化條件的設定

cmo140497

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內,要如何比較各筆之相同位址之資料,是否重覆?如有
重覆並計算重覆次數除以核定片數,作百分比之格式化條件的顏色分類,如下圖所示

下載 (76.08 KB)

2012-12-16 22:05

尋找各組數相同位之是否重覆或獨立之數值作百分比格式化條件.zip (13.93 KB)

下載次數: 11

2012-12-16 22:08

cmo140497

回復 21# Hsieh


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

cmo140497

回復 22# GBKEE

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

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

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

複製代碼

davidju041206

雖無權限下載...仍謝謝您的分享...
努力增加等級中...

cmo140497

回復 17# Hsieh


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

下載 (172.51 KB)

2012-12-19 16:14

cmo140497

回復 17# Hsieh

感謝版主不吝指教,這樣看起來真的簡單多了,對於您的大恩大德,小弟畢生難忘,太感謝您了,謝謝!

Hsieh

回復 16# cmo140497
不知道理解是否正確
將文字檔與程式檔至於同一資料夾試試
RawData.rar (26.7 KB)

下載次數: 14

2012-12-19 01:01

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

回復 15# Hsieh


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

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


多組數之元素重覆次數比較並作條件格式化_2012-12-18.zip (25.28 KB)

下載次數: 10

2012-12-18 14:55