- ©«¤l
- 4901
- ¥DÃD
- 44
- ºëµØ
- 24
- ¿n¤À
- 4916
- ÂI¦W
- 277
- §@·~¨t²Î
- Windows 7
- ³nÅ骩¥»
- Office 20xx
- ¾\ŪÅv
- 150
- ©Ê§O
- ¨k
- ¨Ó¦Û
- ¥x¥_
- µù¥U®É¶¡
- 2010-4-30
- ³Ì«áµn¿ý
- 2024-12-23
|
¦^´_ 1# cmo140497
¸Õ¸Õ¬Ý- Sub AddCheckBox() '¥[¤J®Ö¨ú¤è¶ô
- '¦]¬°¨S¦³´£¨Ñ¤å¦rÀÉ¡A¥H²{¦³Item§@¬°·s¼W±ø¥ó
- 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
½Æ»s¥N½X |
|