- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
9#
發表於 2012-12-17 15:42
| 只看該作者
回復 8# cmo140497
AUTO_OPEN() 檔案開啟時自動執行- Option Explicit
- Sub AUTO_OPEN() '加入核取方塊'因為沒有提供文字檔，以現有Item作為新增條件
- Dim A As Range, K As Integer, i As Integer
- With Sheet1
- .CheckBoxes.Delete
- .Range("B:Z").Interior.ColorIndex = xlNone
- K = Application.CountIf(.Columns("A"), "ID")
- Set A = .Columns("A").Find("ID", lookat:=xlPart)
- For i = 1 To K
- Cells(i + 5, "AA").Select
- With .CheckBoxes.Add(.Cells(i + 5, "AA").Left, .Cells(i + 5, "AA").Top, .Cells(i + 5, "AA").Width, .Cells(i + 5, "AA").Height)
- .Characters.Text = "Item" & i
- .Name = "Item" & i
- .OnAction = "EX" 'CheckBoxes 指巨集的 程式
- End With
- A.Offset(1, 1).Resize(24, 24).Name = "_Item" & i '資料範圍設立名稱:如工作表定義名稱
- Set A = .Columns("A").FindNext(A)
- Next
- '** 製定百分比 為 7 等分 [S1:Y1] 百分比由大到小 ***
- For i = 1 To 7 '百分比由大到小
- .[AA2].Cells(1, i) = 1 + (1 / 7) - (i / 7)
- Next
- End With
- End Sub
- Sub EX() '已執行AUTO_OPEN, 按選CheckBoxes的程式
- Dim Rng(0 To 25) As Range, S, i
- Dim P As Integer, B As CheckBox, E As Variant
- With Sheet1
- .Range("B:Z").Interior.ColorIndex = xlNone
- For Each B In .CheckBoxes
- If B = 1 Then 'CheckBoxe；勾選 = 1
- P = P + 1
- If Not Rng(0) Is Nothing Then
- Set Rng(0) = Union(Rng(0), .Range("_" & B.Name))
- For i = 1 To 24 '已勾選範圍之 第1欄-第24欄
- For Each E In Rng(0).Areas
- Set Rng(i) = Union(E.Columns(i), Rng(i)) '同一欄位 設為同一範圍
- Next
- Next
- Else
- Set Rng(0) = .Range("_" & B.Name)
- For i = 1 To 24
- Set Rng(i) = Rng(0).Columns(i)
- Next
- End If
- End If
- Next
- If P = 0 Then Exit Sub
- Application.ScreenUpdating = False
- For i = 1 To 24 '範圍有24欄
- .Columns(Columns.Count - 1) = "" '清除 最後第2欄資料
- .Columns(Columns.Count) = "" '清除 最後1欄資料
- Rng(i).Copy Cells(1, Columns.Count) '複製欄的資料
- .Columns(Columns.Count).AdvancedFilter xlFilterCopy, .Cells(1, Columns.Count - 1), Unique:=True
- '進階篩選:選取不重複的資料,減少迴圈.
- .Columns(Columns.Count - 1).Sort Key1:=.Cells(1, Columns.Count - 1), Order1:=xlDescending, Header:=xlNo
- '排序 : 不要的資料置於底部
- Set Rng(25) = .Columns(Columns.Count - 1).Cells(1) '設定要尋找的字串
-
- With Rng(i)
- Do Until Rng(25) = "___" Or Rng(25) = "0" Or Rng(25) = ""
- Set Rng(0) = .Find(Rng(25), lookat:=xlWhole)
- If Not Rng(0) Is Nothing Then
- .Replace Rng(25), "=xxx", xlWhole '如同工作表尋找:全部取代 為錯誤的公式
- .SpecialCells(xlCellTypeFormulas).Select
- S = Application.CountA(Selection) / P
- If S <= 1 Then
- S = Application.Match(S, [AA2:AG2], -1) 'Match 的排序:大到小
- Else
- S = 1
- End If
- Selection.Value = Rng(25) '復原 取代的字串
- Selection.Interior.ColorIndex = Sheet1.[AA2].Cells(1, S).Interior.ColorIndex
- End If
- Set Rng(25) = Rng(25).Offset(1) '尋找下一個字串
- Loop
- End With
- Next
- .Columns(Columns.Count - 1) = "" '清除 最後第2欄資料
- .Columns(Columns.Count) = "" '清除 最後1欄資料
- Application.ScreenUpdating = True
- .CheckBoxes(Application.Caller).TopLeftCell.Select
- End With
- End Sub
|
|
發表於 2012-12-17 19:22
| 
