Измените значение на другом листе, установив флажок

Question

После некоторых поисков и попыток разобраться в себе я в тупике. Мне бы пригодилась помощь по этому поводу.

У меня есть книга Excel с несколькими вкладками. Мне нужна помощь с двумя вкладками «KronosEntries» и «MASTER». На вкладке МАСТЕР есть список всех пропущенных дней и отпусков сотрудника. На вкладке KronosEntries есть список всех записей из вкладки MASTER, которые необходимо ввести в Kronos. Как только они будут введены в Kronos, я поставлю галочку рядом с этой строкой, чтобы удалить ее со вкладки KronosEntries. Когда я добавляю новую строку на вкладке MASTER, она автоматически добавляет «Нет» в столбец R. Я хочу, чтобы когда я установил флажок на вкладке KronosEntries, я хочу изменить столбец R на вкладке MASTER на «Да» для строки с такими же данными.

Вот пример вкладки KronosEntries.

Вот пример вкладки MASTER.

Вот что я использовал для добавления флажков.

Sub Addcheckboxes()

'Declare variables and data types
Dim cell, LRow As Single
Dim ChkBx As CheckBox
Dim CLeft, CTop, CHeight, CWidth As Double

'Don't refresh or update screen while processing macro, this will make the macro quicker.
Application.ScreenUpdating = False

'Find last non empty cell in column A
LRow = Worksheets("KronosEntries").Range("A" & Rows.Count).End(xlUp).Row

'Iterate through 2 to last non empty cell
For cell = 2 To LRow

    'Check if cell in column B is not equal to nothing
    If Cells(cell, "B").value <> "" And Cells(cell, "B").value <> "Employee ID" Then

        'Save cell dimensions and coordinates of corresponding cell in column E to variables
        CLeft = Cells(cell, "A").Left
        CTop = Cells(cell, "A").Top
        CHeight = Cells(cell, "A").Height
        CWidth = Cells(cell, "A").Width

        'Create checkbox based on dimension and coordinates data from variables
        Worksheets("KronosEntries").CheckBoxes.Add(CLeft, CTop, CWidth, CHeight).Select

        With Selection
            .Caption = ""
            .value = xlOff
            .LinkedCell = .TopLeftCell.Offset(0, 8).Address
            .Display3DShading = False
        End With

    End If

    Next cell

    Worksheets("KronosEntries").Range("A6").Select

    'Turn on screen refresh
    Application.ScreenUpdating = True

End Sub

Вот что я использовал для удаления флажков.

Sub RemoveCheckboxes()

    'Declare variables and data types
    Dim ChkBx As CheckBox

    'Iterate through all check boxes on active sheet
    For Each ChkBx In Worksheets("KronosEntries").CheckBoxes

        'Remove checkbox
        ChkBx.Delete

    'Continue with next checkbox
    Next

End Sub

Часть, которую я не могу Кажется, разобраться, это код для изменения столбца R на Да для строки с теми же данными. Может кто поможет? Спасибо

Я поместил последний код, который у меня не работает, ниже. Даже не уверен, что я на правильном пути. Я вызываю подпрограмму ChangeData в Worksheet_Calculate.

Sub ChangeData

For Each ChkBx In Worksheets("KronosEntries").CheckBoxes

'If check box is enabled
If ChkBx.value = 1 Then

    'Go through each row on worksheet
    For r = 1 To Rows.Count

        'Check if checkbox is on the same row
        If Cells(r, 1).Top = ChkBx.Top Then

            'Sheet to change value in.
            With Worksheets("MASTER")

               Worksheets("MASTER").Range("R" & r) = Worksheets("KronosEntries").Range("L" & r).value

               End With

               'Exit For Loop
                Exit For
            End If
        Next r
    End If
Next

End Sub

Answer 1

Я использовал другой подход при добавлении данных из вкладки MASTER на вкладку KronosEntries. Я поцарапал старый код и использовал следующее.

кстати, я уверен, что есть лучший способ сделать это, но он работает нормально.

Итак, я добавил кнопку Userform. (Это сохранит необходимые данные на каждой вкладке)

Private Sub AddViolationSave_Click()

            'This adds the data to the MASTER worksheet.
            Dim ws As Worksheet
            Set ws = ThisWorkbook.Sheets("MASTER")
            Dim tbl As ListObject
            'This sets the table to read from.
            Set tbl = ws.ListObjects("MasterList")
            Dim newrow As ListRow
            Set newrow = tbl.ListRows.Add

                With newrow
                'This will add the values needed. The other formulas will automatically fill in. (Range 1 equals cell 1 in the first row)
                .Range(1) = AddEmployeeID.value
                .Range(2) = ComboBox6.value
                .Range(3) = PaidComboBox.value
                .Range(4) = ReasonComboBox.value
                .Range(5) = TypeComboBox.value
                .Range(7) = DateBox.value
                .Range(8) = ChargedComboBox.value
                .Range(9) = PointsComboBox.value
                .Range(10) = Sheets("Database").Range("A91").value
                End With

           'This code will add the data to the KronosEntries tab.
            Dim ws2 As Worksheet
            Set ws2 = ThisWorkbook.Sheets("KronosEntries")
            Dim tbl2 As ListObject
            'This sets the table to read from.
            Set tbl2 = ws2.ListObjects("KronosTable")
            Dim newrow2 As ListRow
            Set newrow2 = tbl2.ListRows.Add

                With newrow2
                'This will add the values needed. The other formulas will automatically fill in. (Range 1 equals cell 1 in the first row)
                .Range(2) = AddEmployeeID.value
                .Range(3) = ComboBox6.value
                .Range(4) = ReasonComboBox.value
                .Range(5) = TypeComboBox.value
                .Range(6) = Sheets("Database").Range("N9").Formula
                .Range(7) = DateBox.value
                End With

            Call Addcheckboxes

            'we will delete the empty lines fromt he table here.
            Dim Rng As Range
            On Error Resume Next
            Set Rng = Range("KronosTable[[Employee ID]]").SpecialCells(xlCellTypeBlanks)
            On Error GoTo 0
            If Not Rng Is Nothing Then
                Rng.Delete Shift:=xlUp
            End If

        MsgBox "New record successfully added.", vbOK + vbExclamation, "Record Added"

End Sub

Затем для подменю данных изменения я использовал это в модуле вместе с AddCheckBoxes и RemoveCheckBoxes выше.

Sub ChangeData()

    'Go through each check box in active sheet
    For Each ChkBx In Worksheets("KronosEntries").CheckBoxes

    'If check box is enabled
    If ChkBx.value = 1 Then

        'Go through each row on worksheet
        For r = 1 To Rows.Count

            'Check if checkbox is on the same row
            If Cells(r, 1).Top = ChkBx.Top Then

                'Will clear the contents of the row where the checkbox is checked.
                Range(ChkBx.LinkedCell).EntireRow.Range("A1:G1").ClearContents
                'Will uncheck the checkbox
                ChkBx.value = -4146

                Exit For
            End If
        Next r
    End If
    Next

    RemoveCheckboxes

    Addcheckboxes

    'This will delete the lines with no data.
    Dim Rng As Range
    On Error Resume Next
    Set Rng = Range("KronosTable[[Employee ID]]").SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not Rng Is Nothing Then
        Rng.Delete Shift:=xlUp
    End If

End Sub