Внесение записи с учетом выбора CheckBox

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Внесение записи с учетом выбора CheckBox (Макросы/Sub)

lebensvoll

Дата: Вторник, 26.03.2019, 06:17 | Сообщение № 1

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

Добрейшего утра Вам всем!!!
В созданной мною теме My WebPage решение было найдено благодаря RAN, спасибо ему огромное
Но за тем в ходе обсуждения с коллегами было принято решение изменить и дополнить условие

Рыская на просторах нашел нужное мне и применил к своему решению. Но не до конца
Условие придумали вот какое
Если оператор установил флажок на CheckBox1 и нажал кнопку внести запись
то запись должна про известись в таблицу лишь 4 раза
Я смог лишь завязать к первому CheckBox и внести запись как будто оператор выбрал все CheckBox
Команда для кнопки

Действие после нажатия

И вроде бы все получается но не могу понять как учесть другие CheckBox и почему не снимаются галочки в них после внесения данных
Почему не очищается сама строка 2 мне ясно (просто пока работаешь над созданием так удобнее чтоб 33 раза не вбивать запись).
Подскажите пжл как выполнить задачу!!!
Спасибо Вам огромнейшее заранее
И прошу простить за то что прикладываю архивный файл

Действие после нажатия

К сообщению приложен файл: 7463428.zip (95.0 Kb)

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Вторник, 26.03.2019, 06:25

Ответить

СообщениеДобрейшего утра Вам всем!!!
В созданной мною теме My WebPage решение было найдено благодаря RAN, спасибо ему огромное
Но за тем в ходе обсуждения с коллегами было принято решение изменить и дополнить условие

Действие после нажатия

Автор - lebensvoll
Дата добавления - 26.03.2019 в 06:17

_Boroda_

Дата: Вторник, 26.03.2019, 10:48 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 16718

Репутация: 6505 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Такой вариант
[vba]

Код

Sub tt()
    For Each ct_ In Me.OLEObjects
        If TypeOf ct_.Object Is MSForms.CheckBox Then
            With ct_.Object
            dd = .Caption
                If .Value Then
'                    n_ = n_ + 1
                    t_ = t_ & ";" & Replace(.Caption, " суток", "")
                    .Value = Not .Value
                End If
            End With
        End If
    Next ct_
    If t_ <> "" Then
        Application.EnableEvents = 0
        r1_ = Cells(Rows.Count, 4).End(xlUp).Row + 1
        ar = Split(t_, ";")
        n_ = UBound(ar)
        Cells(r1_, 1).Resize(4 * n_) = Range("A2")
        Cells(r1_, 2).Resize(4 * n_) = Range("B2")
        Cells(r1_, 3).Resize(4 * n_) = Range("C2")
        Cells(r1_, 4).Resize(4 * n_) = Range("E2")
        Cells(r1_, 5).Resize(4 * n_) = Range("F2")
        Cells(r1_, 8).Resize(4 * n_) = Range("G2")
        Cells(r1_, 22).Resize(4 * n_) = Range("H2")
        For i = 1 To n_
            Cells(r1_ + 4 * (i - 1), 7).Resize(4) = ar(i)
        Next i
        Cells(2, 1).Resize(1, 8).ClearContents
        Application.EnableEvents = 1
    End If
End Sub

Private Sub CommandButton1_Click()
    tt
End Sub

[/vba]
Картинку на листе Класс удалил, она много места занимала

К сообщению приложен файл: __1.xlsb (67.8 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

lebensvoll

Дата: Вторник, 26.03.2019, 20:25 | Сообщение № 3

Группа: Проверенные

Ранг: Старожил

Сообщений: 1002

Репутация: 30 ±

Замечаний: 0% ±

Excel 2010

_Boroda_, добрый вечер Александр... Спасибо Вам огромнейшее за отзывчивость и решение.
Приложенный Вами файл открывает у меня исковерканным, установленный на работе продукт 2007 офис.
Решил перенести код в свой файл копированием.
hands

Удачно!!! Но, в столбец H "Маркировка образца" нумерация должна быть в виде счетчика. Отрывная точка для счетчика указанная оператором во второй строке столбца G.
Я решил вытащить строку кода учитывающее это решение из предыдущей свое темы, но терплю не удачу ((((
[vba]

Код

Sub tt()
    For Each ct_ In Me.OLEObjects 'Макрос для "формы" на листе ЧЕРНОВИК
        If TypeOf ct_.Object Is MSForms.CheckBox Then
            With ct_.Object
            dd = .Caption
                If .Value Then
'                    n_ = n_ + 1
                    t_ = t_ & ";" & Replace(.Caption, " суток", "")
                    .Value = Not .Value
                End If
            End With
        End If
    Next ct_
    If t_ <> "" Then
        Application.EnableEvents = 0
        r1_ = Cells(Rows.Count, 4).End(xlUp).Row + 1 'определяем номер последней строки в табл. Черновик
        ar = Split(t_, ";")
        n_ = UBound(ar)
        Cells(r1_, 1).Resize(4 * n_) = Range("A2")
        Cells(r1_, 2).Resize(4 * n_) = Range("B2")
        Cells(r1_, 3).Resize(4 * n_) = Range("C2")
        Cells(r1_, 4).Resize(4 * n_) = Range("E2")
        Cells(r1_, 5).Resize(4 * n_) = Range("F2")
        Cells(r1_, 8).Resize(4 * n_) = Range("G2")
        Cells(r1_, 22).Resize(4 * n_) = Range("H2")
        For i = 1 To n_
            Cells(r1_ + 4 * (i - 1), 7).Resize(4) = ar(i)
        Next i
        Cells(r1_, 8).AutoFill Destination:=Cells(n, 8).Resize(4), Type:=xlFillSeries 'нумерация счетчик
        Cells(2, 1).Resize(1, 8).ClearContents 'очищаем форму
        Application.EnableEvents = 1
    End If
End Sub

[/vba]
Как у честь этот момент в коде!?
Спасибо огромнейшее заранее

Код

[/vba]
Как у честь этот момент в коде!?
Спасибо огромнейшее заранееlebensvoll

Кто бы ты ни был, мир в твоих руках

Сообщение отредактировал lebensvoll - Вторник, 26.03.2019, 21:26

Ответить

Сообщение_Boroda_, добрый вечер Александр... Спасибо Вам огромнейшее за отзывчивость и решение.
Приложенный Вами файл открывает у меня исковерканным, установленный на работе продукт 2007 офис.
Решил перенести код в свой файл копированием.
hands

Код

[/vba]
Как у честь этот момент в коде!?
Спасибо огромнейшее заранее

Автор - lebensvoll
Дата добавления - 26.03.2019 в 20:25

_Boroda_

Дата: Вторник, 26.03.2019, 22:16 | Сообщение № 4

Группа: Админы

Ранг: Местный житель

Сообщений: 16718

Репутация: 6505 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Тада так
[vba]

Код

Sub tt()
    For Each ct_ In Me.OLEObjects
        If TypeOf ct_.Object Is MSForms.CheckBox Then
            With ct_.Object
            dd = .Caption
                If .Value Then
                    t_ = t_ & ";" & Replace(.Caption, " суток", "")
                    .Value = Not .Value
                End If
            End With
        End If
    Next ct_
    If t_ <> "" Then
        Application.EnableEvents = 0
        r1_ = Cells(Rows.Count, 4).End(xlUp).Row + 1
        ar = Split(t_, ";")
        n_ = UBound(ar)
        Cells(r1_, 1).Resize(4 * n_) = Range("A2")
        Cells(r1_, 2).Resize(4 * n_) = Range("B2")
        Cells(r1_, 3).Resize(4 * n_) = Range("C2")
        Cells(r1_, 4).Resize(4 * n_) = Range("E2")
        Cells(r1_, 5).Resize(4 * n_) = Range("F2")
        Cells(r1_, 22).Resize(4 * n_) = Range("H2")
        For i = 1 To n_
            Cells(r1_ + 4 * (i - 1), 7).Resize(4) = ar(i)
        Next i
        With Cells(r1_, 8)
            .Value = Range("G2")
            .AutoFill Destination:=.Resize(4 * n_)
        End With
        Cells(2, 1).Resize(1, 8).ClearContents
        Application.EnableEvents = 1
    End If
End Sub

[/vba]
Попробуйте этот файл