- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 276
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-12-22
              
|
2#
發表於 2012-12-16 23:47
| 只看該作者
回復 1# cmo140497
試試看- Sub AddCheckBox() '加入核取方塊
- '因為沒有提供文字檔，以現有Item作為新增條件
- With Sheet1
- .CheckBoxes.Delete
- k = Application.CountIf(.Columns("E"), "ID")
- Set A = .Columns("F").Find("Item", lookat:=xlPart)
- For i = 1 To k
- With .CheckBoxes.Add(.Cells(i + 4, "C").Left, .Cells(i + 4, "C").Top, .Cells(i + 4, "C").Width, .Cells(i + 4, "C").Height)
- .Characters.Text = A
- End With
- Set A = .Columns("F").FindNext(A)
- Next
- End With
- End Sub
- Sub 比對()
- Dim Sp As Shape, Rng As Range, A As Range, MyRng As Range
- With Sheet1
- For Each Sp In .Shapes
- If Sp.Name Like "Check Box*" Then
- Set A = .Columns("F").Find(Sp.OLEFormat.Object.Caption)
- If Sp.OLEFormat.Object.Value = 1 Then
- If Rng Is Nothing Then
- Set Rng = A.Offset(1, 0).Resize(5, 5)
- Else
- Set Rng = Union(Rng, A.Offset(1, 0).Resize(5, 5))
- End If
- End If
- End If
- Next
- Set MyRng = .[M3:Q7]
- If Not Rng Is Nothing Then
- For i = 1 To 5
- For j = 1 To 5
- If MyRng(i, j) <> 0 And MyRng(i, j) <> "___" Then
- For Each ar In Rng.Areas
- If ar(i, j) = MyRng(i, j) Then p = p + 1
- Next
- s = p / Rng.Areas.Count: p = 0
- 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))
- MyRng.Cells(i, j).Interior.ColorIndex = .[S2:Y2].Cells(1, n).Interior.ColorIndex
- Else
- MyRng.Cells(i, j).Interior.ColorIndex = -4142
- End If
- Next
- Next
- End If
- End With
- End Sub
|
|
發表於 2012-12-16 22:09
| 
