Как продублировать флажки и при этом чтобы они правильно работали в Excel?

введите сюда описание изображения

Как продублировать флажки для каждой ячейке, при это не копировать каждый флажок и отдельно настраивать, чтобы при включеном флажке показывалась значение, а при выключеном "-",


Ответы (1 шт):

Автор решения: JohnSUN

Макрос действительно очень простой:

    Private Sub RecreateCheckboxes()
    Const cDblCheckboxWidth As Double = 16 ' Ширина и высота будущих чекбоксов
    Const cStrCheckboxPrefix As String = "cbOplata_" ' Часть имени чекбоксов, создаваемых этой процедурой (чтобы не спутать с другими)
    Dim cb As CheckBox  ' Один чекбокс - объект
    Dim rng As Range    ' Диапазон ячеек, к которых чекбоксы будут созданы
    Dim rCell As Range  ' Одна отдельная ячейка из этого диапазона
    Dim i As Long
        Application.ScreenUpdating = False  ' Заморозить экран на время работы макроса
        On Error GoTo beforeExit
        'Сначала удалить все чекбоксы с префиксом cStrCheckboxPrefix, чтобы не создавать дубли
        For Each cb In CheckBoxes
            If Left(cb.Name, Len(cStrCheckboxPrefix)) = cStrCheckboxPrefix Then cb.Delete
        Next
    
        Set rng = ... ' Каким-нибудь способом определить диапазон, например, [D5:D30] 
        For Each rCell In rng
    'Разместить новый чекбокс в ячейке
            Set cb = CheckBoxes.Add( _
                rCell.Left + rCell.Width / 2 - cDblCheckboxWidth / 2, _
                rCell.Top, cDblCheckboxWidth, rCell.Height)
    
    'Задать свойства нового чекбокса
            With cb
                .Name = cStrCheckboxPrefix & rCell.Address(False, False) 'Имя чекбокса будет вроде "cbOplata_D7"
                .Value = rCell.Value    ' Сразу взвести или сбросить чекбокс в зависимости от значения в ячейке 
                .LinkedCell = rCell.Address ' Привязать чекбокс к своей ячейке
                .Display3DShading = True
                .Characters.Text = ""
            End With
    'Чтобы подавить вывод ИСТИНА/ЛОЖЬ в ячейке - спрячем любое её содержимое
            rCell.NumberFormat = ";;;"
        Next rCell
    beforeExit:
        Application.ScreenUpdating = True ' Разморозить экран 
    End Sub

Будем считать, что настоящее значение для оплаты есть в какой-то предыдущей ячейке, а в колонке "Сума для передоплати" только формулы вида

=IF(D7;B7;"-")
=ЕСЛИ(D7;B7;"-")

Не проверял, но должно работать Проверил. Возможно, перед обоими CheckBoxes нужно добавить указание на лист - ActiveSheet.CheckBoxes или что-то подобное.

→ Ссылка