Создание макроса, который устанавливает / снимает флажки Все в пределах диапазона переменных, как определено

Question

Макрос предназначен для поиска местоположения основного флажка (application.caller) и затем выбора всех флажков в этом столбце до 14 строк ниже. Мой лист имеет различные флажки в другом месте, текущий макрос проверяет ВСЕ флажки на листе. Что я делаю не так?

Sub SelectAll_Click()
'Select / Clear All macro
Dim xCheckBox As CheckBox, n As Variant, rng As Range, loc As Range, loc1 As Range
'Application.Caller.Name
n = ActiveSheet.CheckBoxes(Application.Caller).Name

With ActiveSheet

Set loc = ActiveSheet.CheckBoxes(Application.Caller).TopLeftCell
'Set loc1 = loc.Address
'MsgBox loc1
loc.Select
Set rng = Range(loc.Address, ActiveCell.Offset(13, 0))
MsgBox (rng.Address)
End With




For Each xCheckBox In Application.ActiveSheet.CheckBoxes
'MsgBox (xCheckBox.TopLeftCell.Address)
'With xCheckBox.Select
   If Not Intersect(loc, rng) Is Nothing Then

        If xCheckBox.Name <> Application.ActiveSheet.CheckBoxes(n).Name Then
       ' If Not Intersect(rngShp, rng) Is Nothing Then

        xCheckBox.Value = Application.ActiveSheet.CheckBoxes(n).Value
        End If

    End If
    'End With

    Next
    End Sub

Answer 1

Следующее верно для всех флажков, которые не являются флажками, на которых вы щелкнули.

If xCheckBox.Name <> Application.ActiveSheet.CheckBoxes(n).Name Then
    xCheckBox.Value = Application.ActiveSheet.CheckBoxes(n).Value
End If

Вам необходимо дополнительно проверить, пересекается ли xCheckBox.TopLeftCell с требуемым диапазоном rng. Так что это верно только для всех других флажков, которые TopLeftCell находятся в пределах диапазона:

If xCheckBox.Name <> Application.ActiveSheet.CheckBoxes(n).Name And Not Intersect(xCheckBox.TopLeftCell, rng) Is Nothing Then
    xCheckBox.Value = Application.ActiveSheet.CheckBoxes(n).Value
End If

---

Наконец, ваш код может выглядеть примерно так:

Option Explicit

Public Sub SelectAll_Click()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim MasterChkBox As CheckBox
    Set MasterChkBox = ws.CheckBoxes(Application.Caller)


    Dim MasterLocation As Range
    Set MasterLocation = ws.CheckBoxes(Application.Caller).TopLeftCell

    Dim Rng As Range
    Set Rng = MasterLocation.Resize(RowSize:=14)

    'MsgBox (Rng.Address)

    Dim xCheckBox As CheckBox
    For Each xCheckBox In ws.CheckBoxes
        If xCheckBox.Name <> MasterChkBox.Name And _
           Not Intersect(xCheckBox.TopLeftCell, Rng) Is Nothing Then

            xCheckBox.Value = MasterChkBox.Value

        End If
    Next xCheckBox
End Sub

^{Изображение 1: Если вы отметите главный блок, он выберет только 13 полей под главным блоком.}