[50期]在VBA中使用循环批量修改工作表中复选框属性。

nyafullee · 发表于 2009-8-14 17:19

多谢楼主:

以下是本人的答案:楼主辛苦,请审阅!!!!!!!

1、答案一：

上面的附件有一点小错误!!!请楼主以以下附件为准审阅,
多谢,辛苦了!!!!

2、答案二：

3、答案三：

[ 本帖最后由 nyafullee 于 2009-8-18 16:47 编辑 ]

mobuli · 发表于 2009-8-22 09:59

shape.OLEFormat.Object.Object

unsamesky · 发表于 2009-8-22 09:59

原帖由 好123 于 2009-8-8 12:10 发表
Sub VBA_4()
Dim obj As Object, shp As Shape
Dim s(1 To 8) As Variant, b As String, h As Long, i As Long
Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
For Each shp ...

喜欢这种代码结构！！！
学习！！！

zjdh · 发表于 2009-8-23 08:33

ActiveSheet.Shapes.Range(F).Group 中
为何F数组从0到7就出错?
非要1到8，
逼得我只能用很笨的语句Group。

zldccmx · 发表于 2009-8-23 19:17

以下是老朽的答案，供参考：
   '撰写:老朽
   '网址:http://Club.ExcelHome.net
   '日期:2009-8-23 下午 07:16:16
Sub Zldccmx()
Application.ScreenUpdating = False
Dim A, My_Ws, I, Forc, T_o, Lef1, Lef2
Set My_Ws = CreateObject("ScriptControl") '创建一个ScriptControl对象
My_Ws.Language = "VBScript" '通知系统，脚本语言为VBScript
My_Ws.AddObject "ActiveSheet", ThisWorkbook.ActiveSheet '由于VBS无法直接识别出EXCEL对象保留字ActiveSheet，所以必须这样来处理，通知VBS _
                                                            ActiveSheet就是ThisWorkbook.ActiveSheet，也就是本工作簿中活动的工作表对象
' 同样，如果在脚本中将要引用Thisworkbook对象，也必须事先设定： _
      My_Ws.AddObject "Thisworkbook", ThisWorkbook  通知VBS，代码中的ThisWorkbook就是本工作簿对象
T_o = [C6].Top: Lef1 = [C6].Left: Lef2 = [F6].Left
For I = 1 To 16
      Forc = IIf(I Mod 3 = 1, vbRed, IIf(I Mod 3 = 2, vbBlue, vbCyan))
      Select Case I
      Case 1 To 8
         A = "With ActiveSheet.CheckBox" & I & ":.Caption=" & Chr(34) & "CheckBox" & I & Chr(34) & ":.Top =" & T_o & "+(" & I & "-1)*.Height : .Value = Not .Value : .Left =" & Lef1 & ":.linkedcell=" & Chr(34) & "IV" & I & Chr(34) & ":.ForeColor=" & Forc & " : End With"
      Case 9
         A = "With ActiveSheet.CheckBox" & I & ":.Caption=" & Chr(34) & "CheckBox" & I & Chr(34) & ":.Top = " & T_o & ": .Value = Not .Value : .Left =" & Lef2 & ":.linkedcell=" & Chr(34) & "IV" & I & Chr(34) & ":.ForeColor=" & Forc & " : End With"
      Case 10 To 16
         A = "With ActiveSheet.CheckBox" & I & ":.Caption=" & Chr(34) & "CheckBox" & I & Chr(34) & ": .Value = Not .Value : .linkedcell=" & Chr(34) & "IV" & I & Chr(34) & ":.ForeColor=" & Forc & " : End With"
      End Select
      My_Ws.ExecuteStatement A
Next
Set My_Ws = Nothing '清除刚刚创建的ScriptControl对象，节约系统资源
Application.ScreenUpdating = True
End Sub

zldccmx · 发表于 2009-8-23 19:32

原帖由 amulee 于 2009-7-28 15:06 发表

amulee 给出了4种方案，其中两种方案使用了类模块。
首先，插入一个名为MyCls的类模块，代码如下：
Private MyShape As Shape
Public Sub Attach(MyObj)
Set MyShape = MyObj
SetShape
End Sub
Private Sub SetShape()
Dim i%, ColorInd&
i = Mid(MyShape.Name, 9, Len(MyShape.Name))
With MyShape
      .Left = Sheet1.Cells(6, (i \ 9) * 3 + 3).Left
      .Top = Sheet1.Cells(6, (i \ 9) * 3 + 3).Top + (IIf(i > 8, i - 8, i) - 1) * .Height
      ColorInd = WorksheetFunction.Choose((i Mod 3) + 1, RGB(0, 255, 255), RGB(255, 0, 0), RGB(0, 0, 255))
      .OLEFormat.Object.Object.Caption = .Name
      .OLEFormat.Object.LinkedCell = "IV" & i
      .OLEFormat.Object.Object.Value = Not .OLEFormat.Object.Object.Value
      .OLEFormat.Object.Object.ForeColor = ColorInd
End With
End Sub
之后，在标准模块中，使用如下四种方案
Dim chkbox2(1 To 16) As New MyCls
Sub 方法1() '直接设置,直接找出各个复选框
Dim i%, ColorInd&, chkbox(1 To 16)
For i = 1 To 8
      Set chkbox(i) = Sheet1.Shapes("CheckBox" & i)
Next i
For i = 9 To 16
      Set chkbox(i) = Sheet1.Shapes("组合 42").GroupItems.Item(i - 8)
Next i
For i = 1 To 16
      With chkbox(i)
         .Left = Sheet1.Cells(6, (i \ 9) * 3 + 3).Left
         .Top = Sheet1.Cells(6, (i \ 9) * 3 + 3).Top + (IIf(i > 8, i - 8, i) - 1) * .Height
         ColorInd = WorksheetFunction.Choose((i Mod 3) + 1, RGB(0, 255, 255), RGB(255, 0, 0), RGB(0, 0, 255))
         .OLEFormat.Object.Object.Caption = .Name
         .OLEFormat.Object.LinkedCell = "IV" & i
         .OLEFormat.Object.Object.Value = Not .OLEFormat.Object.Object.Value
         .OLEFormat.Object.Object.ForeColor = ColorInd
      End With
Next i
End Sub
Sub 方法2() '类模块
Dim i%
For i = 1 To 8
      chkbox2(i).Attach Sheet1.Shapes("CheckBox" & i)
Next i
For i = 9 To 16
      chkbox2(i).Attach Sheet1.Shapes("组合 42").GroupItems.Item(i - 8)
Next i
End Sub
Sub 方法3() '通过图形的类别找出复选框
Dim i%, obj, obj2
i = 1
For Each obj In Sheet1.Shapes
      If obj.Type = 12 Then
         chkbox2(i).Attach obj
         i = i + 1
      End If
      If obj.Type = 6 Then
         For Each obj2 In obj.GroupItems
            If obj2.Type = 12 Then
                  chkbox2(i).Attach obj2
                  i = i + 1
            End If
         Next
      End If
Next
End Sub
Sub 方法4() '取消组合,设置完成后再组合
Dim i%, obj, Arr(9 To 16)
For Each obj In Sheet1.Shapes '取消组合
      If obj.Type = 6 Then obj.Ungroup
Next
For i = 1 To 16  '通过类模块设置对象
      chkbox2(i).Attach Sheet1.Shapes("CheckBox" & i)
Next i
For i = 9 To 16  '重新组合
      Arr(i) = "CheckBox" & i
Next i
Sheet1.Shapes.Range(Arr).Select
Selection.ShapeRange.Group.Name = "组合 42"
End Sub

老朽意见：经测试，4种方法均符合要求，建议给2分

[ 本帖最后由 zldccmx 于 2009-8-23 21:21 编辑 ]

zldccmx · 发表于 2009-8-23 19:47

原帖由 gg19782002 于 2009-8-5 22:18 发表

Sub VBA_4()
Dim s As String
Dim sh As Shape
Dim arr()
Dim i, k As Integer
Application.EnableEvents = False
k = 1
With Sheet1
      .Unprotect
      For Each sh In .Shapes
         If sh.Type = msoGroup Then sh.Ungroup
      Next
      For i = 1 To 16
         s = "CheckBox" & i
         If .OLEObjects(s).Object.Value = True Then
            .OLEObjects(s).Object.Value = False
         Else
            .OLEObjects(s).Object.Value = True
         End If
'老朽注：用这一句可以替代上面的　if then else endif
'.OLEObjects(s).Object.Value = Not .OLEObjects(s).Object.Value
         .OLEObjects(s).Object.Caption = s
         .OLEObjects(s).LinkedCell = .Range("iv" & i).Address
         If i Mod 3 = 1 Then
            .OLEObjects(s).Object.ForeColor = RGB(255, 0, 0)
         Else
            If i Mod 3 = 2 Then
                  .OLEObjects(s).Object.ForeColor = RGB(0, 0, 255)
            Else
                  If i Mod 3 = 0 Then
                     .OLEObjects(s).Object.ForeColor = RGB(0, 255, 255)
                  End If
            End If
         End If
'老朽注：同样，用下面这一句可以替代上面嵌套的　if then else　if　....
'.OLEObjects(s).Object.ForeColor = Choose((i Mod 3) + 1, vbRed, vbBlue, vbCyan)
         If i = 1 Then
            .OLEObjects(s).Left = .Cells(6, 3).Left
            .OLEObjects(s).Top = .Cells(6, 3).Top
         Else
            If i = 9 Then
                  .OLEObjects(s).Left = .Cells(6, 6).Left
                  .OLEObjects(s).Top = .Cells(6, 6).Top
            Else
                  .OLEObjects(s).Left = .OLEObjects("CheckBox" & i - 1).Left
                  .OLEObjects(s).Top = .OLEObjects("CheckBox" & i - 1).Top + .OLEObjects("CheckBox" & i - 1).Height
            End If
         End If
         ReDim Preserve arr(1 To k)
         If i > 8 Then
            arr(k) = s
            k = k + 1
         End If
      Next
      .Shapes.Range(arr).Group
End With
Application.EnableEvents = True
End Sub

经测试，代码无误，建议可以得1分。

zldccmx · 发表于 2009-8-23 20:02

原帖由 泓() 于 2009-8-6 22:08 发表

Sub VBA_4()
'---by 泓()
Application.ScreenUpdating = False
On Error Resume Next
Dim Obj As Object
Dim Shp As Shape, s As Shape
Dim Arr()
For Each Shp In ActiveSheet.Shapes
      If Shp.Type = msoGroup Then 'If Shp.Name Like "Group*" Then
         Shp.Left = [F6].Left: Shp.Top = [F6].Top
         For Each s In Shp.GroupItems
            n = n + 1: ReDim Preserve Arr(1 To n)
            Arr(n) = s.Name
         Next
         ActiveSheet.Shapes(Shp.Name).Ungroup
      End If
Next
With ActiveSheet
      t = .[C6].Top: h = .OLEObjects("CheckBox1").Height
      For I = 1 To 16
         .Cells(I, 256) = Not (.Cells(I, 256))
         .OLEObjects("CheckBox" & I).Object.Caption = "CheckBox" & I
         .OLEObjects("CheckBox" & I).LinkedCell = "IV" & I
         If I <= 8 Then
            .OLEObjects("CheckBox" & I).Left = .[C6].Left
            .OLEObjects("CheckBox" & I).Top = t + (I - 1) * h
         End If
         If I Mod 3 = 1 Then
            .OLEObjects("CheckBox" & I).Object.ForeColor = RGB(255, 0, 0)
         ElseIf I Mod 3 = 2 Then
            .OLEObjects("CheckBox" & I).Object.ForeColor = RGB(0, 0, 255)
         Else
            .OLEObjects("CheckBox" & I).Object.ForeColor = RGB(0, 255, 255)
         End If
'老朽注：同样，用下面这一句可以替代上面嵌套的　if then elseif　....
'.OLEObjects("CheckBox" & I).Object.ForeColor = Choose((i Mod 3) + 1, vbRed, vbBlue, vbCyan)
      Next
      ActiveSheet.Shapes.Range(Arr).Group
End With
Application.ScreenUpdating = True
End Sub

'老朽意见：答案基本正确，不过参赛选手本身有技术分10分＞参赛门槛要求的≤3分，能否加分请版主定夺。
不过，建议版主，如果不加分，加点财富吧，算是一种鼓励！

[ 本帖最后由 zldccmx 于 2009-8-23 21:19 编辑 ]

zldccmx · 发表于 2009-8-23 20:06

原帖由 好123 于 2009-8-8 12:10 发表

Sub VBA_4()
'By 好123
Dim obj As Object , shp As Shape
Dim s(1 To 8) As Variant , b As String , h As Long , i As Long
Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
For Each shp In .Shapes
      If shp.Name Like "Group*" Then
         shp.Left = [f6].Left
         shp.Top = [f6].Top
         .Shapes(shp.Name).Ungroup
      End If
Next
b = "CheckBox"
h = .OLEObjects(b & 1).Height
For i = 1 To 16
      Cells(i, "IV") = Not (Cells(i, "IV"))
      With .OLEObjects(b & i)
         .Object.Caption = b & i
         .LinkedCell = "IV" & i
         If i < 9 Then
            .Left = [c6].Left
            .Top = [c6].Top + (i - 1) * h
         Else
            s(i - 8) = b & i
         End If
         If i Mod 3 = 1 Then
            .Object.ForeColor = RGB(255, 0, 0)
         ElseIf i Mod 3 = 2 Then
            .Object.ForeColor = RGB(0, 0, 255)
         Else
            .Object.ForeColor = RGB(0, 255, 255)
         End If
'老朽注：同样，用下面这一句可以替代上面嵌套的　if then else　if　....
'.Object.ForeColor = Choose((i Mod 3) + 1, vbRed, vbBlue, vbCyan)
      End With
Next
.Shapes.Range(s).Group
End With
Application.ScreenUpdating = True
End Sub

老朽意见：经测试代码无误，符合要求，可以得1分。

[ 本帖最后由 zldccmx 于 2009-8-23 20:07 编辑 ]

zldccmx · 发表于 2009-8-23 20:12

原帖由 mobuli 于 2009-8-11 08:37 发表

Option Explicit
' By MoBuli

Sub VBA_4()
  Dim objOLE As OLEObject, i As Integer
  Call 取消组合
  For Each objOLE In ActiveSheet.OLEObjects
   If objOLE.progID = "Forms.CheckBox.1" Then objOLE.Object.Caption = objOLE.Name '只有是复选框，标签名称等于控件名称
  Next
  Call 排列过程
  Call 设置颜色
  For Each objOLE In ActiveSheet.OLEObjects '设置逻辑开关功能
If objOLE.progID = "Forms.CheckBox.1" Then objOLE.Object.Value = Not objOLE.Object.Value
  Next
  Call 组合(9, 16) '组合9～16的控件
End Sub
Sub 排列过程()
  Dim shp As Shape
  Dim i As Integer
  Dim sngTopa As Single
  Dim sngLefta As Single
  Dim sngTopb As Single
  Dim sngLeftb As Single
  Dim sngShapeHeight As Single
  sngTopa = Range ("C6").Top
  sngLefta = Range ("C6").Left
  sngTopb = Range ("F6").Top
  sngLeftb = Range ("F6").Left
  For Each shp In ActiveSheet.Shapes
If shp.Type = msoOLEControlObject And InStr(1, shp.Name, "CheckBox") <> 0 Then
   i = i + 1
   If i < 9 Then
      ActiveSheet.Shapes("CheckBox" & i).Top = sngTopa
      ActiveSheet.Shapes("CheckBox" & i).Left = sngLefta
      sngShapeHeight = shp.Height
      sngTopa = sngTopa + sngShapeHeight
   Else
      ActiveSheet.Shapes("CheckBox" & i).Top = sngTopb
      ActiveSheet.Shapes("CheckBox" & i).Left = sngLeftb
      sngShapeHeight = shp.Height
      sngTopb = sngTopb + sngShapeHeight
   End If
End If
  Next
End Sub
Sub 取消组合()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
   If shp.Type = msoGroup Then shp.Ungroup
Next
End Sub
Sub 设置颜色()
Dim i As Integer , j As Integer
For i = 1 To ActiveSheet.OLEObjects.Count
j = i Mod 3
If j = 1 Then
   ActiveSheet.OLEObjects("CheckBox" & i).Object.ForeColor = 255
ElseIf j = 2 Then
   ActiveSheet.OLEObjects("CheckBox" & i).Object.ForeColor = 16711680
Else
   ActiveSheet.OLEObjects("CheckBox" & i).Object.ForeColor = 16776960
End If
ActiveSheet.OLEObjects("CheckBox" & i).LinkedCell = "IV" & i
  Next i
End Sub
Sub 组合(intSta As Integer , intEnd As Integer )
Dim i As Integer
Dim strCheck As String
Dim strTemp As String
Dim arr
For i = intEnd To intSta Step -1
   strTemp = "CheckBox" & i
   strCheck = strTemp & " " & strCheck
Next i
ActiveSheet.Shapes.Range(Split(Trim(strCheck))).Group
End Sub

老朽意见：测试失败，ActiveSheet.Shapes.Range(Split(Trim(strCheck))).Group　无法通过

[ 本帖最后由 zldccmx 于 2009-8-23 20:18 编辑 ]

		自动登录	找回密码
密码			免费注册

[Excel 程序开发] [50期]在VBA中使用循环批量修改工作表中复选框属性。

[50期]nyafullee上交的答案

本帖子中包含更多资源

评分