GBKEE

回復 10# cmo140497
你的資料顯示是2003版 何不在2003試看
測試12# 2010版 需是

1. .Columns(Columns.Count).AdvancedFilter xlFilterCopy, , .Cells(1, Columns.Count - 1), Unique:=True

複製代碼

cmo140497

回復 11# GBKEE


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

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

下載次數: 2

2012-12-17 16:41

cmo140497

回復 11# GBKEE


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



尋找各組數相同位之是否重覆或獨立之數值作百分比格式化條件_已回覆_修正1.zip (40.28 KB)

下載次數: 5

2012-12-17 17:00

cmo140497

回復 4# Hsieh


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


[attach]13583[/attach]


[attach]13584[/attach]

Hsieh

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

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

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

回復 17# Hsieh

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

cmo140497

回復 17# Hsieh


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

下載 (172.51 KB)

2012-12-19 16:14

davidju041206

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