两个目的没有达到，求大神帮忙

jhhkh · 发表于 2024-10-4 22:48

本帖最后由 jhhkh 于 2024-10-4 23:06 编辑

求助.rar (71.69 KB, 下载次数: 24)

我通过VBA生成多个复选框，我想达到以下两个效果
1。勾选除最下面任何一个复选框，右侧的单元格背景变浅绿色

2. 勾选最下面一个复选框，这一列上面的复选框都被勾选，右侧的一列有数据的所有单元格背景变浅绿色

不知道什么原因，上传压缩文件再次下载，提示文件损坏，所以只好压缩两次，才没有问题，用两次压缩里面的Excel

taller · 发表于 2024-10-5 01:30

Sub InsertCheckboxesAndHideText()
Dim ws As Worksheet
Dim col As Long
Dim row As Long
Dim cb As Object
Dim colArray As Variant
Dim i As Long
Dim FC As FormatCondition, sCell As String, eCell As String
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets("初始赋值")
' 指定需要插入复选框的列：A, C, E, G, ..., Q（隔列）
colArray = Array(1, 3, 5, 7, 9, 11, 13, 15, 17) ' 这些是列号
Application.ScreenUpdating = False
' 遍历指定列并在第2行到第16行中插入复选框
For i = LBound(colArray) To UBound(colArray)
col = colArray(i)
' 在每列的2到16行中插入复选框
With ws.Cells(row, col)
For row = 2 To 17
' 插入复选框
Set cb = ws.CheckBoxes.Add(.Left, .Top, .Width, .Height)
cb.Caption = "" ' 去掉复选框的标题
cb.linkedCell = .Address ' 将复选框与所在单元格链接
cb.Display3DShading = True ' 设置复选框为三维阴影效果
' 设置单元格字体颜色为与背景相同，使TRUE或FALSE不可见
.Font.Color = .Interior.Color ' 字体颜色设置为与背景颜色相同
Next row
End With
' ** 设置条件格式
With ws.Cells(2, col + 1).Resize(15, 1)
sCell = .Cells(1).Offset(0, -1).Address(0, 1)
eCell = .Cells(.Cells.Count).Offset(1, -1).Address(1, 0)
Set FC = .FormatConditions.Add(Type:=xlExpression, Formula1:="=OR(" & sCell & "," & eCell & ")")
FC.Interior.Color = vbGreen
End With
Next i
Application.ScreenUpdating = True
End Sub
Sub RemoveFC()
Dim FC
For Each FC In ActiveSheet.Cells.FormatConditions
FC.Delete
Next
End Sub
Sub 删除所有复选框() ' 简化代码
Dim ws As Worksheet
Dim cb As CheckBox
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets("初始赋值")
ws.DrawingObjects.Delete
' 遍历并删除工作表中的所有复选框
' For Each cb In ws.CheckBoxes
' cb.Delete
' Next cb
End Sub

复制代码

taller · 发表于 2024-10-5 01:31

3190496160 · 发表于 2024-10-5 09:43

Sub 复选框1()
Dim i As Byte, s As Byte
r = Cells(Rows.Count, 1).End(xlUp).row
With ActiveSheet
For i = 1 To .CheckBoxes.Count
      l = .CheckBoxes(i).TopLeftCell.Column + 1
      h = .CheckBoxes(i).TopLeftCell.row
      If h < r Then
         If .CheckBoxes(i).Value = 1 Then
            .Cells(h, l).Interior.ColorIndex = 4
         Else
            .Cells(h, l).Interior.ColorIndex = 0
         End If
      End If
Next i
End With
End Sub
Sub 复选框2()
Dim i As Byte, s As Byte
r = Cells(Rows.Count, 1).End(xlUp).row
With ActiveSheet
For i = 1 To .CheckBoxes.Count
      l = .CheckBoxes(i).TopLeftCell.Column + 1
      h = .CheckBoxes(i).TopLeftCell.row
      If h = r Then
         If .CheckBoxes(i).Value = 1 Then
            For s = 1 To .CheckBoxes.Count
                  If .CheckBoxes(s).TopLeftCell.Column = l - 1 Then
                     .CheckBoxes(s) = True
                     If .Cells(.CheckBoxes(s).TopLeftCell.row, l) <> "" Then .Cells(.CheckBoxes(s).TopLeftCell.row, l).Interior.ColorIndex = 4
                  End If
            Next s
         Else
            For s = 1 To .CheckBoxes.Count
                  If .CheckBoxes(s).TopLeftCell.Column = l - 1 Then
                     .CheckBoxes(s) = False
                     .Cells(.CheckBoxes(s).TopLeftCell.row, l).Interior.ColorIndex = 0
                  End If
            Next s
         End If
      End If
Next i
End With
End Sub
Sub 指定宏()
With ActiveSheet
For i = 1 To .CheckBoxes.Count
      hh = .CheckBoxes(i).TopLeftCell.row
      .Shapes.Range(Array("Check Box " & i)).Select
      If hh = 17 Then
         Selection.OnAction = "复选框2"
      Else
         Selection.OnAction = "复选框1"
      End If
Next i
End With
End Sub

3190496160 · 发表于 2024-10-5 09:44

123.rar (37.36 KB, 下载次数: 2)

3190496160 · 发表于 2024-10-5 09:51

4楼附件有误，以此为准

123.rar (37.74 KB, 下载次数: 10)

Qs18 · 发表于 2024-10-5 14:08

Sub qs()
Application.ScreenUpdating = False
Dim rng As Range, r As Range
Set rng = Sheet3.Range("a2:r16")
For Each r In rng
If r.Value = True Then
' MsgBox r.Offset(0, 1).Value
r.Offset(0, 1).Interior.Color = 65535
Else
r.Offset(0, 1).Interior.Pattern = xlNone
End If
Next
Application.ScreenUpdating = True
End Sub
Sub InsertCheckboxesAndHideText()
Dim ws As Worksheet
Dim col As Long
Dim row As Long
Dim cb As Object
Dim colArray As Variant
Dim i As Long
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets("初始赋值")
' 指定需要插入复选框的列：A, C, E, G, ..., Q（隔列）
colArray = Array(1, 3, 5, 7, 9, 11, 13, 15, 17) ' 这些是列号
' 遍历指定列并在第2行到第16行中插入复选框
For i = LBound(colArray) To UBound(colArray)
col = colArray(i)
' 在每列的2到16行中插入复选框
For row = 2 To 17
m = m + 1
' 插入复选框
Set cb = ws.CheckBoxes.Add(ws.Cells(row, col).Left, ws.Cells(row, col).Top, ws.Cells(row, col).Width, ws.Cells(row, col).Height)
cb.Caption = "" ' 去掉复选框的标题
cb.linkedCell = ws.Cells(row, col).Address ' 将复选框与所在单元格链接
cb.Display3DShading = True ' 设置复选框为三维阴影效果
cb.Name = "cx" & m
If m Mod 16 = 0 Then
cb.OnAction = "sq" '绑定的宏
Else
cb.OnAction = "qs" '绑定的宏
End If
' 设置单元格字体颜色为与背景相同，使TRUE或FALSE不可见
ws.Cells(row, col).Font.Color = ws.Cells(row, col).Interior.Color ' 字体颜色设置为与背景颜色相同
Next row
Next i
End Sub
Sub sq()
For c = 1 To 17 Step 2
If Sheet3.Cells(17, c) = True Then
Sheet3.Cells(17, c).Offset(-15, 0).Resize(15, 1) = True
Call qs
Else
Sheet3.Cells(17, c).Offset(-15, 0).Resize(15, 1) = False
Call qs
End If
Next c
End Sub
Sub 删除所有复选框()
Dim ws As Worksheet
Dim cb As CheckBox
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets("初始赋值")
' 遍历并删除工作表中的所有复选框
For Each cb In ws.CheckBoxes
cb.Delete
Next cb
End Sub

复制代码

Qs18 · 发表于 2024-10-5 14:09

试试.........

山海风云轩 · 发表于 2024-10-5 15:07

做个记号，学习学习

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

[求助] 两个目的没有达到，求大神帮忙