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

nyafullee

多谢楼主:

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

1、答案一：



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



2、答案二：



3、答案三：



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

mobuli

shape.OLEFormat.Object.Object

unsamesky

原帖由 好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

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

zldccmx

以下是老朽的答案，供参考：
      '撰写:老朽
      '网址: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

原帖由 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

原帖由 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-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

原帖由 好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

原帖由 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 编辑 ]