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

zldccmx

原帖由 蓝桥玄霜 于 2009-8-12 16:08 发表

Sub VBA_4()
'by 蓝桥玄霜
    Dim i%, nm$, shp, aa, n%
    Dim Sht As Worksheet
    Application.ScreenUpdating = False
    On Error Resume Next
    Set Sht = ActiveSheet
    Do
    For Each shp In Sht.Shapes
        n = InStr(shp.Name, "Group")
        If n > 0 Then
            nm = shp.Name
            Exit For
        End If
    Next
    With Sht.Shapes(nm)
        .Top = [f6].Top
        .Left = [f6].Left
        .Select
        Selection.ShapeRange.Ungroup
    End With
    Loop While n <> 0
    For i = 1 To 16
        With Sht.OLEObjects("CheckBox" & i)
            .Object.Caption = .Name
            .Object.Value = Not .Object.Value
            .LinkedCell = Sht.Cells(i, "iv")
            aa = i Mod 3
            Select Case aa
                Case 0
                    .Object.ForeColor = vbCyan
                Case 1
                    .Object.ForeColor = vbRed
                Case 2
                    .Object.ForeColor = vbBlue
            End Select
            If i = 1 Then
                .Top = [c6].Top
            End If
            If i = 1 Then
                .Left = [c6].Left
                .Top = [c6].Top
            ElseIf i < 9 Then
                .Top = Sht.OLEObjects("CheckBox" & i - 1).Top + Sht.OLEObjects("CheckBox" & i - 1).Height
                .Left = [c6].Left
            End If
        End With
    Next
    aa = "CheckBox9"
    For i = 10 To 16
        ActiveSheet.Shapes.Range(Array(aa, "CheckBox" & i)).Select
        Selection.ShapeRange.Group.Select
        aa = Selection.Name
    Next i
    [a1].Select
Application.ScreenUpdating = True
End Sub

老朽意见：经测试，代码正确，可以得分。


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

zldccmx

原帖由 unsamesky 于 2009-8-12 16:55 发表

Sub VBA_4()
  Dim shp As Shape
  Dim valName As Integer
  Dim i As Byte
  Dim StrA As String
  With Sheet1
    .Unprotect
    For Each shp In .Shapes  '解散组合
      If shp.Type = msoGroup Then shp.Ungroup
    Next
    For i = 1 To 16
      .OLEObjects("CheckBox" & i).Object.Caption = .OLEObjects("CheckBox" & i).Name '更改所有复选框的标题
      If i - 8 > 0 Then     '对齐左边缘
         .OLEObjects("Checkbox" & i).Left = .Columns(6).Left
      Else
         .OLEObjects("Checkbox" & i).Left = .Columns(3).Left
      End If
      If i Mod 8 = 1 Then   '对齐上边缘
         .OLEObjects("Checkbox" & i).Top = .Rows(3).Top
      Else
         .OLEObjects("Checkbox" & i).Top = .OLEObjects("Checkbox" & i - 1).Top + .OLEObjects("Checkbox" & i - 1).Height
      End If
      Select Case i Mod 3  '各复选按钮显示变色
        Case 1: .OLEObjects("Checkbox" & i).Object.ForeColor = vbRed
        Case 2: .OLEObjects("Checkbox" & i).Object.ForeColor = vbBlue
        Case 0: .OLEObjects("Checkbox" & i).Object.ForeColor = 16776960
      End Select
      '对所有按钮的value属性取反
      .OLEObjects("CheckBox" & i).Object.Value = Not .OLEObjects("CheckBox" & i).Object.Value
      '设定IV列单元格的值，不是很明白题目的意思！！！
      .Cells(i, "IV") = .OLEObjects("CheckBox" & i).Object.Value
    Next
    '重新组合
    .Shapes.Range(Array("CheckBox9", "CheckBox10", "CheckBox11", "CheckBox12", _
                        "CheckBox13", "CheckBox14", "CheckBox15", "CheckBox16")).Group
    .Protect
  End With
End Sub


Sub VBA_5()
  Dim shp As Shape
  Dim valName As Integer
  Dim i As Byte
  Dim StrA As String
  Dim sh As Shape
  With Sheet1
    .Unprotect
    For Each shp In .Shapes
      If shp.Type = msoGroup Then
         For Each sh In shp.GroupItems    '对组合中的各个元素进行操作
             sh.OLEFormat.Object.Object.Caption = sh.Name '更改标题
             sh.OLEFormat.Object.Object.ForeColor = vbRed     '更改标题色彩
             sh.OLEFormat.Object.Object.Value = Not sh.OLEFormat.Object.Object.Value   '对value取反
             If Len(sh.Name) = 9 Then i = Right(sh.Name, 1) Else i = Right(sh.Name, 2)
             .Cells(i, "IV") = sh.OLEFormat.Object.Object.Value
         Next
         shp.Top = .[g6].Top    '组合上边距与g6对齐
         shp.Left = .[g6].Left  '左边距与g6对齐
      Else
         '对非组合元素（即独立控件）进行操作
         If shp.Name Like ("CheckBox*") Then
             shp.DrawingObject.Object.Caption = shp.Name '更改复选框的标题
         '对齐左边缘
             shp.Left = Sheet1.Columns(4).Left
        '各复选按钮显示变色
            shp.DrawingObject.Object.ForeColor = vbBlue
        '对所有按钮的value属性取反
            shp.OLEFormat.Object.Object.Value = Not shp.OLEFormat.Object.Object.Value
        '设定IV列单元格的值，不是很明白题目的意思！！！
            .Cells(Right(shp.Name, 1), "IV") = shp.OLEFormat.Object.Object.Value
         End If
      End If
   Next
      .OLEObjects("CheckBox1").Top = .[d6].Top
      .OLEObjects("CheckBox1").Left = .[d6].Left
      For i = 2 To 8
      .OLEObjects("CheckBox" & i).Top = .OLEObjects("CheckBox" & i - 1).Top + .OLEObjects("CheckBox" & i - 1).Height
      .OLEObjects("CheckBox" & i).Left = .[d6].Left
      Next
   .Protect
  End With
End Sub
老朽意见：两种方案均没有设置控件的LinkedCell属性，第二方案更没有按要求设置控件的ForeColor属性，有点遗憾。

zldccmx

原帖由 zjdh 于 2009-8-14 14:02 发表

Sub Macro3()
' By zjdh
    On Error Resume Next
    Dim h As Object
    Dim c As Object
    Dim A%, B%, T%, W%, D
    A = 0
    B = Range ("c6").Left
    T = Range ("c6").Top
    For Each h In Sheets(1).Shapes
        If h.Name Like "Group*" Then h.Ungroup.Select
    Next
    For W = 1 To 16
        N = "CheckBox" & W
        For Each c In Sheets(1).OLEObjects
            D = c.Object.Value
            If c.Name Like N Then
                With c
                    .Top = T + A
                    .Left = B
                    .LinkedCell = "IV" & W
                End With
                With c.Object
                    Select Case W Mod 3
                    Case 1
                        .ForeColor = 255
                    Case 2
                        .ForeColor = 16711680
                    Case 0
                        .ForeColor = 16776960
                    End Select
                    .Value = Not (D)
                    .Caption = "CheckBox" & W
                End With
                A = A + c.Height
                If W = 8 Then A = 0: B = Range ("F6").Left: T = Range ("F6").Top
            End If
        Next
    Next
    '组合
    ActiveSheet.Shapes.Range(Array("CheckBox9", "CheckBox10", "CheckBox11", "CheckBox12", _
                             "CheckBox13", "CheckBox14", "CheckBox15", _
                             "CheckBox16")).Group.Select
'老朽注：组合这句代码与题意不符，题目要求使用循环来实现,如果是多个控件呢？
    Range ("A25").Select
'老朽注：代码中多处使用了Select,在VBA中请尽量不使用Select
End Sub

老朽意见：代码基本正确，唯一不足的就是最后组合控件时没有采用循环，有点遗憾。能否加分，请版主决断。
其实好多人都赶往了误区，可以不解散与组合的。

zldccmx

原帖由 nyafullee 于 2009-8-14 17:19 发表

提供了三种方案
Sub VBA_4()
'By nyafullee
Dim top_c6#, top_f6#
Dim i%, s$, arr1(1 To 8), arr2(1 To 8)
top_c6 = Sheet1.Range("c6").Top: top_f6 = Sheet1.Range("f6").Top
'''''''''''''''''''''''''''''''''
s = "CheckBox"
For i = 1 To 8
    arr1(i) = s & i
Next
''''''''''''''''''''''''''''''''''
Dim c1 As New Collection, v As OLEObject
For i = 1 To 8
    For Each v In Sheet1.OLEObjects
        If arr1(i) = v.Name Then c1.Add v
    Next
Next
For i = 1 To 8
Set v = c1(i)
    '''''''''''''''''''''''
    Select Case i Mod 3
    Case 1:
        c1(i).Object.ForeColor = 255
    Case 2:
        c1(i).Object.ForeColor = 16711680
    Case 0:
        c1(i).Object.ForeColor = 16776960
    End Select
    '''''''''''''''''''''
    c1(i).LinkedCell = Sheet1.Range("IV" & i).Address(0, 0): c1(i).Object.Caption = c1(i).Name
    c1(i).Left = 108: c1(i).Height = 27
    If i = 1 Then c1(i).Top = top_c6 Else c1(i).Top = top_c6 + (i - 1) * 27
    c1(i).Object.Value = Not c1(i).Object.Value
Next
'''''''''''''''''''''''''''''''''''''''''
For i = 1 To 8
    arr2(i) = Sheet1.Shapes(9).GroupItems(i).Name
'老朽注：由于使用了Shapes的索引号9来引用组合，所以用原始附件时就会出错
Next
'''''''''''''''''''''
Sheet1.Shapes(9).Ungroup
For i = 1 To 8
    For Each v In Sheet1.OLEObjects
    If arr2(i) = v.Name Then
    v.Left = 270: v.Height = 27: v.LinkedCell = Sheet1.Range("iv" & i + 8).Address(0, 0): v.Object.Caption = v.Name: v.Object.Value = Not v.Object.Value
    If i = 1 Then v.Top = top_f6 Else v.Top = top_f6 + (i - 1) * 27
    Select Case i Mod 3
    Case 1
        v.Object.ForeColor = 16776960
    Case 2
        v.Object.ForeColor = 255
    Case 0
        v.Object.ForeColor = 16711680
    End Select
    Exit For
    Else
    End If
    Next
Next
Sheet1.Shapes.Range(arr2).Group
End Sub
第二种方案
Sub VBA_4()
'By nyafullee
Dim i%, arr1(1 To 16), arr2(1 To 8), sh As Shape, s$, ol As OLEObject
Dim top_c6#, top_f6#
Dim c As New Collection
s = "CheckBox": top_c6 = Sheet1.Range("c6").Top: top_f6 = Sheet1.Range("f6").Top
''''''''''''''''''''''''''''''
For i = 1 To 16
If i < 9 Then arr1(i) = s & i Else arr2(i - 8) = s & i: arr1(i) = s & i
Next
'''''''''''''''''''''''''''''
For Each sh In Sheet1.Shapes
If sh.Name Like "Group*" Then sh.Ungroup
Next
''''''''''''''''''''''''''''''
For Each ol In Sheet1.OLEObjects
ol.Object.Caption = ol.Name: ol.Height = 27: ol.Object.Value = Not ol.Object.Value
Next
For i = 1 To 16
    For Each ol In Sheet1.OLEObjects
    If arr1(i) = ol.Name Then
        If i < 9 Then
        ol.LinkedCell = Sheet1.Range("iv" & i).Address(0, 0): ol.Left = 108
        ol.Top = top_c6 + (i - 1) * 27
        Else
        ol.LinkedCell = Sheet1.Range("iv" & i).Address(0, 0): ol.Left = 270
        ol.Top = top_f6 + (i - 9) * 27
        End If
        '''''''''''''''''
        Select Case i Mod 3
        Case 1
            ol.Object.ForeColor = &HFF&
        Case 2
            ol.Object.ForeColor = &HFF0000
        Case 0
            ol.Object.ForeColor = &HFFFF00
        End Select
    Else
    End If
    Next
Next
'''''''''''''''''''''''''''''''''
Sheet1.Shapes.Range(arr2).Group
End Sub

第三种方案见楼下：

zldccmx

原帖由 nyafullee 于 2009-8-14 17:19 发表

第三方案是采用宏中宏的方式，但是，遗憾的是，非要两次点出按钮

Sub VBA_43()
'By nyafullee
Dim rows_line%, i%, s$, ss$, exit_nya As Boolean
exit_nya = ThisWorkbook.VBProject.VBComponents("模块1").CodeModule.Find("Public Sub nyafullee", 70, 1, 10000, 1, False , False )
If exit_nya = False Then
    top_c6 = Sheet1.Range("c6").Top: top_f6 = Sheet1.Range("f6").Top: s = "CheckBox"
    For i = 1 To 8
    ss = ss & "," & s & i + 8
    Next
    ss = Right(ss, Len(ss) - 1)
    Sheet1.Shapes(9).Ungroup
    With ThisWorkbook.VBProject.VBComponents("模块1")
    rows_line = .CodeModule.CountOfLines + 5
    .CodeModule.InsertLines rows_line, "public sub nyafullee()"
    rows_line = .CodeModule.CountOfLines + 1
    .CodeModule.InsertLines rows_line, "dim top_c6#,top_f6#,s$": rows_line = .CodeModule.CountOfLines + 1
    .CodeModule.InsertLines rows_line, "top_c6 = Sheet1.Range(""c6"").Top: top_f6 = Sheet1.Range(""f6"").Top"
    rows_line = .CodeModule.CountOfLines + 1
    '''''''''''''''''''''''''''''''''''''
    For i = 1 To 16
    .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".Height=27:sheet1." & s & i & ".Caption=sheet1." & s & i & ".name:" & _
                                    "sheet1." & s & i & ".LinkedCell=sheet1.range(""iv" & i & """).address(0,0):" & _
                                    "sheet1." & s & i & ".value=not sheet1." & s & i & ".value"
    rows_line = .CodeModule.CountOfLines + 1
    Next
    '''''''''''''''''''''''''''''''''''''
    For i = 1 To 16
    If i < 9 Then
    .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".left=108:sheet1." & s & i & ".top =top_c6 + " & (i - 1) * 27
    rows_line = .CodeModule.CountOfLines + 1
    Else
    .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".left=270:sheet1." & s & i & ".top =top_f6 + " & (i - 9) * 27
    rows_line = .CodeModule.CountOfLines + 1
    End If
    Next
    '''''''''''''''''''''''''''''''''''''
    For i = 1 To 16
    Select Case i Mod 3
    Case 1
        .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".forecolor=&HFF&"
        rows_line = .CodeModule.CountOfLines + 1
    Case 2:
        .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".forecolor=&HFF0000"
        rows_line = .CodeModule.CountOfLines + 1
    Case 0
        .CodeModule.InsertLines rows_line, "sheet1." & s & i & ".forecolor=&HFFFF00"
        rows_line = .CodeModule.CountOfLines + 1
    End Select
    Next
    '''''''''''''''''''''''''''''''''''
    .CodeModule.InsertLines rows_line, "g": rows_line = .CodeModule.CountOfLines + 1
    .CodeModule.InsertLines rows_line, "end sub"
    End With
    ''''''''''
    MsgBox "已经生成相应的代码!!!" & vbCrLf & vbCrLf & "请继续点击""试一试按钮""!!!" & vbCrLf & vbCrLf & "以查看此代码产生的变化!!"
Else
    Application.Run "nyafullee"
End If
End Sub


Sub g()
Dim arr(1 To 8), s$, i%, a#, b#
s = "CheckBox"
For i = 1 To 8
arr(i) = s & i + 8
Next
Sheet1.Shapes.Range(arr).Group
With ThisWorkbook.VBProject.VBComponents("模块1").CodeModule
a = .ProcCountLines("nyafullee", vbext_pk_Proc)
b = .ProcBodyLine("nyafullee", vbext_pk_Proc)
.DeleteLines b, a
End With
End Sub

老朽意见：纵观选手的三种方案，无一例外的均使用了绝对数值来设置控件的高度、左边距、顶边距，用选手的话说就是为了确保与原始效果图一致。
三种方案均能满足要求，并且增加了一个图片实时显示各控件LinkedCell的值，这是一个比较新颖的做法，值得学习。
最后一种方案，采用实时添加宏的办法，有点遗憾，设计不够完美，有待继续研究。

综上所述：三种方案基本满足要求，建议版主加分。


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

好123

有时间时学习一下

zldccmx

从本次竞赛中，有选手使用了类模块来完成，值得大家借鉴；
还有一种方案就是使用了宏中宏的方法，只可惜选手没有对代码进行完善。
不过，其中的一些方法值得大家借鉴。考虑到大家对宏中宏不太熟悉，所以老朽特别提练出来，与大家分享。

1、判断指定模块中是否已经存在某一个过程

exit_nya = ThisWorkbook.VBProject.VBComponents("模块1").CodeModule.Find("Public Sub nyafullee", 70, 1, 10000, 1, False, False)
老朽注：最好是使用遍历各个模块，而不是只限于某一个模块，因为同一工作簿的各模块中是不允许存在同名字的过程的。

2、统计某模块已经占用的行数

rows_line = ThisWorkbook.VBProject.VBComponents("模块1") .CodeModule.CountOfLines

3、插入一段模块：

1. 
   
2.     With ThisWorkbook.VBProject.VBComponents("模块1").CodeModule
   
3.         rows_line = .CountOfLines + 1
   
4.         .InsertLines rows_line, "Sub VBA_EH()"
   
5.         rows_line = rows_line + 1
   
6.         .InsertLines rows_line, "Msgbox ""http://club.excelhome.net/thread-464375-3-1.html"""
   
7.         rows_line = rows_line + 1
   
8.         .InsertLines rows_line, "End Sub"
   
9.     End With
   

复制代码

4、计算特定过程首行所在的行数

b = ThisWorkbook.VBProject.VBComponents("模块1").CodeModule.ProcBodyLine("nyafullee", vbext_pk_Proc)

5、返回特定过程的行数。

a = ThisWorkbook.VBProject.VBComponents("模块1").CodeModule.ProcCountLines("nyafullee", vbext_pk_Proc)

6、删除指定的代码段

ThisWorkbook.VBProject.VBComponents("模块1").CodeModule.DeleteLines b, a

应该说，通过本次竞赛，大家从各位选手的代码中可以吸取一些营养，各取所需。
老朽没有“总结”的经验，权当是老朽的随笔吧。

[ 本帖最后由 zldccmx 于 2009-8-24 16:58 编辑 ]

ldy

这个题目主要针对通过字符串变量动态引用工作表中控件的问题。
排除 脚本方法，VBE方法（代码写代码），excel本身提供了多种方式可以通过字符串来引用控件。
CallByName 方法 可以透过组合直接访问控件，可以不用取消组合。
另外 通过 OLEObjects，Evaluate ，Shapes 不可以直接访问组合中的控件，需要先取消组合后再重新组合。
但可以通过 访问组合的GroupItems属性逐个访问。

1. 
   
2. Sub ldy1()
   
3.     For i = 1 To 16
   
4.         With CallByName(Sheet1, "CheckBox" & i, VbGet)   
   
5.             If i < 10 Then
   
6.                 .Left = Sheet1.Cells(6, (i \ 9) * 3 + 3).Left
   
7.                 .Top = Sheet1.Cells(6, (i \ 9) * 3 + 3).Top + (IIf(i > 8, i - 8, i) - 1) * .Height
   
8.             End If
   
9.             .Caption = .Name
   
10.             .LinkedCell = "IV" & i
    
11.             .Value = Not .Value
    
12.             .ForeColor = Choose((i Mod 3) + 1, vbRed, vbBlue, vbCyan)
    
13.         End With
    
14.     Next
    
15. End Sub
    

复制代码

1. 
   
2. 
   
3. Sub ldy2_3_4()
   
4. Dim chk As MSForms.CheckBox
   
5.     For Each obj In Sheet1.Shapes
   
6.         If obj.Type = 6 Then
   
7.             nm = obj.Name
   
8.             ReDim arr(0 To obj.GroupItems.Count - 1)
   
9.             obj.Ungroup '取消组合
   
10.         End If
    
11.     Next
    
12.     For i = 1 To 16
    
13.         Set chk = Sheet1.OLEObjects("CheckBox" & i).Object                   '方法2
    
14.         Set chk = Sheet1.Evaluate("CheckBox" & i).Object                        '方法3
    
15.         Set chk = Sheet1.Shapes("CheckBox" & i).DrawingObject.Object  '方法4
    
16.         With chk
    
17.             .Left = Sheet1.Cells(6, (i \ 9) * 3 + 3).Left
    
18.             .Top = Sheet1.Cells(6, (i \ 9) * 3 + 3).Top + (IIf(i > 8, i - 8, i) - 1) * .Height
    
19.             .Caption = .Name
    
20.             .LinkedCell = "IV" & i
    
21.             .Value = Not .Value
    
22.             .ForeColor = Choose((i Mod 3) + 1, vbRed, vbBlue, vbCyan)
    
23.             If i > 8 Then arr(i - 9) = .Name
    
24.         End With
    
25.     Next
    
26.     Sheet1.Shapes.Range(arr).Group.Name = nm '重新组合
    
27. End Sub
    

复制代码

zldccmx

MoBuLi在代码是2003下测试失败，

但是在2007下正常，请版主给予评分

zldccmx

请版主重新对6楼的作品进行评分!