Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1 2 След.
RSS
VBA добавить чек-бокс на лист и сохранить его значение в массив
 
Здравствуйте,

Может ли кто помочь с такой не хитрой задачей: из модуля хочу добавить на лист (с привязкой к ячейке) чек-бокс и далее читать его состояние (true/false) и сохранять в массив.
И что лучше выбрать Формы или ActiveX тоже не понимаю, хоть и гуглил. Не доходит до меня...

Демо-файлик прикрепил.
Заранее, благодарю.
 
prostor,

Код
'Добавить чек-бокс
Sub ActiveAdd()
    Dim chBox As Object
    For Each el In Range([A2], [A2].End(xlDown))
        Set chBox = ActiveSheet.CheckBoxes.Add(el.Offset(0, 2).Left, el.Offset(0, 2).Top, el.Offset(0, 2).Width, el.Offset(0, 2).Height)
        chBox.LinkedCell = el.Offset(0, 3).Address(True, True)
    Next el
End Sub
' Удалить чек-бокс
Sub ActiveDelete()
    Dim chBox As Object
    For Each el In ActiveSheet.CheckBoxes
        el.Delete
    Next el
End Sub

'Снять показания чек-боксов и записать в массив
    Sub ActiveRead()
        Dim myArray As Variant
        myArray = Application.Transpose(Range([D2], [D2].End(xlDown)).Value)        
        For i = 1 To UBound(myArray)
            MsgBox i & " = " & myArray(i)
        Next i
    End Sub
 
tolstak, спасибо, все сработало.

Маленький нюансик остался - как снимать показания именно с чек-бокса, без участия колонки D ? Ну и добавлять в нее тоже ничего не надо, соответственно :)
---
Разобрался только, что эта строка добавляет показание чек-бокса - закоментировал ее...
Код
chBox.LinkedCell = el.Offset(0, 3).Address(True, True)

А вот как теперь снять показание с самого чек-бокса - разобраться не могу....
Изменено: prostor - 11 Авг 2017 19:34:35
 
prostor, тогда чуть усложняем словарем и такой-то матерью)
Код
Public chkBoxDic As Object

'Добавить чек-бокс
Sub ActiveAdd()
    ActiveDelete
    Set chkBoxDic = CreateObject("Scripting.Dictionary")
    Dim chBox As Object
    For Each el In Range([A2], [A2].End(xlDown))
        Set chBox = ActiveSheet.CheckBoxes.Add(el.Offset(0, 2).Left, el.Offset(0, 2).Top, el.Offset(0, 2).Width, el.Offset(0, 2).Height)
        'chBox.LinkedCell = el.Offset(0, 3).Address(True, True)
        chBox.Caption = el.Value
        chBox.Name = el.Value
        Set chkBoxDic(chBox.Name) = chBox
    Next el
End Sub
' Удалить чек-боксы
Sub ActiveDelete()
    Dim chBox As Object
    If Not chkBoxDic Is Nothing Then Set chkBoxDic = Nothing
        For Each el In ActiveSheet.CheckBoxes
            el.Delete
        Next el
End Sub
 
' Снять показания чек-бокса без обращения к ячейкам
Sub readDictionary()
    If chkBoxDic Is Nothing Then Exit Sub
    Dim el As Object
    For i = 0 To chkBoxDic.Count - 1
        Set el = chkBoxDic.Items()(i)
        MsgBox i & ": " & chkBoxDic.Keys()(i) & " = " & IIf(el.Value = -4146, False, True)
    Next i
End Sub

'Снять показания чек-боксов и записать в массив
Sub ActiveRead()
    myArray = Application.Transpose(Range([D2], [D2].End(xlDown)).Value)
    For i = 1 To UBound(myArray)
        MsgBox i & " = " & myArray(i)
    Next i
End Sub

Я не понимаю почему, но значение при отмеченной галке - 1, а при не выбранной - -4146 , но преобразование типа  
Код
IIf(a.Value = -4146, False, True)
работает. Тут вот тот же вопрос проскакивал.
Может, более опытные товарищи подскажут почему так.
 
tolstak, огромное спасибо! все работает.

По поводу -4146, думаю не проблема. это значение вроде как постоянное, значит с ним можно работать. верно понимаю?:)
 
prostor, да, так и есть. Просто непонятная какая-то константа... :)
 
tolstak, Приветствую:)

Допиливаю ваш пример под себя и столкнулся с такой сложностью: хочу использовать ActiveAdd как процедуру с параметрами, вызывать из другого модуля, но не могу сообразить как правильно организовать вызов, с использованием цикла
Код
For Each el In Range([A2], [A2].End(xlDown)) ...

Прошу вашей помощи по этому поводу:) Файл приложил...

Заранее, благодарю.
 
prostor,  посмотрите в файле. Вероятно, что i и j - строка и столбец, изменил процедуру соответствующим образом. Работает,но сложилось ощущение, что вставляется не совсем так как Вами задумывалось :)
Изменено: tolstak - 16 Авг 2017 20:19:47
 
tolstak, спасибо, все как надо, чуток подправил под себя

По ходу дела, возникла такая ситуация, что после закрытия файла и повторного открытия - считать показания чек-боксов нельзя. При этом сам excel сохраняет галочки на чек-боксах, а значит оно в прицепи где-то есть в самом файле excel, на диске...

Я понимаю, что идет чтение из словаря, пока он живой. Но интересно, как то ведь можно снимать показания с чек-боксов после "закрыл-открыл файл"?

Прикладываю файлик..
 
prostor, у Вас красивая логика присвоения имен чек-боксам.
Можно просто обратиться к ним по этим красивым именам.
Можно даже и без словаря обойтись в таком случае, ну да пусть будет :)
Код
Sub readDictionary()
    If chkBoxDic Is Nothing Then
        ' Еще побарахтаемся!
        'Exit Sub
        
        Dim j As Long, i As Long, cbClient As String, cbCaption As String, dicItem As String
        Set chkBoxDic = CreateObject("Scripting.Dictionary")
        'Перейти на новую строку
        For j = 2 To 18 'Цикл шага вниз, не менять. В рабочей версии - шаг динамический.
            cbClient = Cells(j, 1)
            For i = 5 To 7
                
                Select Case i
                Case 5
                cbCaption = "Да"
                Case 6
                cbCaption = "Нет"
                Case 7
                cbCaption = "Неизвестно"
                End Select
                
                dicItem = cbClient & ":" & cbCaption
                chkBoxDic.Add Key:=dicItem, Item:=ActiveSheet.CheckBoxes(dicItem)
            Next i
            j = j + 3
        Next j
    End If
    
    
    Dim el As Object
    
    
    For i = 0 To chkBoxDic.Count - 1
        Set el = chkBoxDic.Items()(i)
        MsgBox chkBoxDic.Keys()(i) & ":" & IIf(el.Value = -4146, False, True)
    Next i
End Sub
 
tolstak, спасибо:) стараюсь, учусь...

В этом варианте все срабатывает в идеале. Только не могу понять что происходит в этой строке
Код
chkBoxDic.Add Key:=dicItem, Item:=ActiveSheet.CheckBoxes(dicItem)
 
prostor,  в словарь chkBoxDic добавить элемент с ключом dicItem (Ваше название а-ля (Михаил.Нет.0)) и содержанием - элементом чек-бокс активного листа с именем dicItem (Ваше название а-ля (Михаил.Нет.0))
 
tolstak, верно понимаю, что IF срабатывает когда в памяти нет словаря (после закрыл-открыл файл) - далее создается нужный словарь и в него снимается текущее состояние чек-боксов?

Сорри за дотошность, не очень хорошо еще разбираюсь в коде, хочу все-все понять...:)
 
Вот тут
Код
For i = 0 To chkBoxDic.Count - 1
        Set el = chkBoxDic.Items()(i)
        MsgBox chkBoxDic.Keys()(i) & ":" & IIf(el.Value = -4146, False, True)
Next i

я обычно использую такой код
Код
For Each ikey In  chkBoxDic.Keys
    Set el =  chkBoxDic.Item(ikey) 
    MsgBox ikey & ":" & IIf(el.Value = -4146, False, True)
next ikey
вроде как быстрей считается    
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, хм, действительно, выглядит изящней :)
prostor, да, так и есть. if VAR is nothing then определяет, что переменной VAR не присвоено значение. Далее мы в нее запихиваем то что есть на листе, правила наименования мы знаем.
В случае, если что-то переменной уже присвоено - подразумеваем, что именно то, что нам нужно, и с этим работаем.
 
tolstak, Nordheim, спасибо за вашу помощь! :)

Начинаю чуток лучше разбираться в коде, мне это нравится..:)
 
Уже было подумал, что все интересное позади, но не тут то было:) Веселье продолжается...

Такая вот ситуация: 3 колонки * 1000 строк = 3000 чекбоксов...
Итог: excel подвисает, минуты на две при добавлении чекбоксов на лист и выдает ошибку при попытке удаления чекбоксов макросом. Ну и еще притормаживает (самую малость) при скроле листа.
Вопрос: что в таких ситуация обычно делают профи? :))))

Все, на что хватило моих знаний, - отключить всякую активность excel при старте модуля и включить на финише...
Дальше пропасть. Прошу вашей помощи! Файлик с демо-данными приложил.
 
prostor, ну, на мой взгляд, нужно понимать ограничения программы :) Все же не рассчитана она на такое... Возможно, имеет смысл динамически - для редактируемой колонки создавать три чекбокса, с привязкой к ячейкам. Для остальных - удалять чекбоксы и хранить только значение.
По удалению попробуйте так:
Код
         For i = ActiveSheet.CheckBoxes.Count To 1 Step -1
            ActiveSheet.CheckBoxes(i).Delete
         Next i
'        For Each el In ActiveSheet.CheckBoxes
'            el.Delete
'        Next el
 
prostor, CheckBox нужно все удалить одновременно? Если все то можно так.
Код
Sub test()
ActiveSheet.CheckBoxes.Delete
End Sub
Изменено: Nordheim - 19 Авг 2017 13:21:47
"Все гениальное просто, а все простое гениально!!!"
 
tolstak, Nordheim, а можно как-то сделать, что бы сама ячейка реагировала на клик (событие) и красилась в цвет, без чекбоксов... ну и дальше снимать с ячейки цвет...? как вариант...:)
---

Или как вариант 2: поместить на лист три кнопки (Да, Нет, Неизвестно) и нажатие на кнопку добавляло значение в ячейку ряда, а выделение ряда менялось бы динамически вниз, после нажатия одной из кнопки... Только кнопки должны быть плавающие - менять положение следом за скролом:)
Изменено: prostor - 19 Авг 2017 15:14:31
 
prostor, можно, но к
Цитата
VBA добавить чек-бокс на лист и сохранить его значение в массив
отношения это уже явно не имеет, должна быть отдельная тема ;-)
 
Попробуйте, может так скорость возрастет и тормоза пропадут, но не факт.
Код
Option Explicit

Sub test()
Dim dic1 As Object, i%, ikey, cell As Range
Set dic1 = CreateObject("Scripting.Dictionary")
For i = 1 To 3000
    dic1.Add CheckBoxes, 0
Next i
Set cell = Range("a1"): i = 1
Application.ScreenUpdating = False
For Each ikey In dic1.keys
    i = i +1
    cell(i, 1) = ikey.Add(cell(i, 1).Left, cell(i, 1).Top, cell(i, 1).Width, cell(i, 1).Height)
Next ikey
Columns(1).ClearContents
Application.ScreenUpdating = True
End Sub
Код
Sub test1()
ActiveSheet.CheckBoxes.Delete
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, что то вообще не заводится... выдает ошибку на строке dic1.Add CheckBoxes, 0. Что то про ассоциации...((
 
А может вместо настоящих ЧекБоксов использовать псевдо-чекбоксы? Не упростится задача? )
Шрифт Marlett - латинская "а"
 
Думал об этом тоже... Но тогда возникает еще такой вопрос:
Возможно ли как то прикрутить к этому псевдо-чекбоксу, такие же свойства реагирования на события, как у настоящего. А именно: клик левой кнопкой мыши, кнопка пробел на клавиатуре?
 
Цитата
prostor написал:
Nordheim , что то вообще не заводится... выдает ошибку на строке dic1.Add CheckBoxes, 0. Что то про ассоциации...((
Код
Sub test()
Dim dic1 As Object, i%, ikey, cell As Range
With ActiveSheet
    Set dic1 = CreateObject("Scripting.Dictionary")
    For i = 1 To 3000
        dic1.Add .CheckBoxes, 0
    Next i
    Set cell = .Range("a1"): i = 1
    Application.ScreenUpdating = False
    For Each ikey In dic1.keys
        i = i + 1
        cell(i, 1) = ikey.Add(cell(i, 1).Left, cell(i, 1).Top, cell(i, 1).Width, cell(i, 1).Height)
    Next ikey
    .Columns(1).ClearContents
End With
Application.ScreenUpdating = True
End Sub
Изменено: Nordheim - 21 Авг 2017 08:26:18
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
prostor написал:
Возможно ли как то прикрутить к этому псевдо-чекбоксу, такие же свойства реагирования на события
Ввод указанного символа - уже событие.  
 
Цитата
Юрий М написал:
Ввод указанного символа - уже событие.  
Вввод символа это понятно. но всетаки хочется полный аналог чек-бокса, но без "этих тяжелых элементов". Типа, левыый клик по ячейке - отрисовалась галочка...

В случае, если вариант только ввода символа с клавиатуры, - принципиальной разницы нет, что вводить, на мой взгляд, хоть букву Ё :)
 
Вы же сами говорили, что не хотите пользоваться мышкой ))
Цитата
prostor написал:
ипа, левыый клик по ячейке - отрисовалась галочка...
Можно: событие Worksheet_SelectionChange, но тогда возможны непреднамеренные срабатывания (при ошибочном выделении ячейки мышкой или клавишами управления курсором).
Предпочтительнее использовать Worksheet_BeforeDoubleClick или Worksheet_BeforeRightClick.
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target(1).Address(0, 0) = "A1" Then
        Application.EnableEvents = False
        If Len(Target(1)) Then
            If Right(Target(1), 1) = " " Then
                Target(1).Value = Empty
            Else
                Target(1).Font.Name = "Wingdings"
                Target(1).Value = "ю"
            End If
        End If
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target(1).Address(0, 0) = "A1" Then
        If Len(Target(1)) Then
            Target(1).Value = Empty
        Else
            Target(1).Font.Name = "Wingdings"
            Target(1).Value = "ю"
        End If
    End If
End Sub
Изменено: RAN - 21 Авг 2017 19:45:25
Страницы: 1 2 След.
Читают тему (гостей: 1)