checkbox在所选单元格行上运行macros; 需要他们在链接的单元格行上运行

我有一个工作簿，在这个工作簿中，一个工作人员将完成特定的项目，一旦完成，他们将被完成检查。 这会触发checkbox左侧的行/范围被选中，复制并粘贴到第一个可用行的下一个工作表中。 当前行将从第一个工作表中清除。 每个工作表都有预先填入并预先链接到单元格的checkbox。 我遇到的问题是，当选中checkbox时，runallmacros将在当前选中的行上激活，而不是checkbox所在的行，并链接到单元格中。例如，如果checkbox是M2行，但是当前select的单元格是B8，macros将尝试复制和粘贴第8行，而不是预期的第2行。由于macros没有撤消，这导致很大的头痛。 任何帮助将不胜感激！

Sub RUNALLOPEN() Dim response As VbMsgBoxResult response = MsgBox("Are you sure you wish to clear this row and send to the Lab?", vbYesNo + vbExclamation, "Confirm Error Resolution") If response = vbNo Then Dim cbx As CheckBox Set cbx = ActiveSheet.CheckBoxes(Application.Caller) With cbx.TopLeftCell.Offset(0, -1) cbx.Value = xlOff End With Exit Sub End If If response = vbYes Then 'rest of code Call movedataOPEN2LAB Call clearcellsOPEN End If End Sub Sub movedataOPEN2LAB() Dim cbx As CheckBox 'Application.Caller returns the name of the CheckBox that called this macro Set cbx = ActiveSheet.CheckBoxes(Application.Caller) '.TopLeftCell returns the cell address located at the top left corner of the cbx checkbox With cbx.TopLeftCell.Offset(0, -1) 'Check the checkbox status (checked or unchecked) If cbx.Value = xlOn Then ' Checkbox is Checked Range(Cells(cbx.TopLeftCell.Offset(0, -1).Row, 1), Cells(cbx.TopLeftCell.Offset(0, -1).Row, 11)).Select Selection.Copy Sheets("Lab").Select Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveSheet.Paste ActiveSheet.Range("H" & Selection.Row).Formula = "=VLOOKUP(INDIRECT(""G"" & ROW()),'Source Data'!$D$1:$J$36,6,FALSE)" ActiveSheet.Range("I" & Selection.Row).Value = "Lab" Range("A2").Select End If End With End Sub Sub clearcellsOPEN() On Error Resume Next Worksheets("Open").Activate Range(Cells(Selection.Row, 1), Cells(Selection.Row, 15)).Select Selection.SpecialCells(xlCellTypeConstants).ClearContents Range(Cells(Selection.Row, 1), Cells(Selection.Row, 1)).Select End Sub 

感谢您的帮助！ 以下是我想到的：

 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 13 Then 'If UCase(Target.Value) <> "X" Then ' Dim response As VbMsgBoxResult ' response = MsgBox("You must input 'x' in order to move this row.", vbOKOnly + vbExclamation, "ERROR") ' Exit Sub ' End If If UCase(Target.Value) = "X" Then response = MsgBox("Are you sure you wish to clear this row and send to the Lab?", vbYesNo + vbExclamation, "Confirm Error Resolution") If response = vbNo Then Target.Value = "" Exit Sub End If If response = vbYes Then 'rest of code Target.Cells.Offset(0, -12).Select Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 11)).Select Selection.Copy With Sheets("Lab") .Select .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select End With ActiveSheet.Paste ActiveSheet.Range("H" & Selection.Row).Formula = "=VLOOKUP(INDIRECT(""G"" & ROW()),'Source Data'!$D$1:$J$36,6,FALSE)" ActiveSheet.Range("I" & Selection.Row).Value = "Lab" With Sheets("Open") .Select On Error Resume Next Target.Cells.Offset(0, -12).Select Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 14)).Select Selection.SpecialCells(xlCellTypeConstants).ClearContents End With End If End If End If End Sub 

Answer 1

还有很多其他的方法可以完成这个任务，比起checkbox来，我想到的“更清洁”就是使用工作表的Change事件。

1. 摆脱checkbox
2. 将列M的标题设置为“Completed = X”

3. 在Table对象中使用这个代码：

   Private Sub Worksheet_Change（ByVal目标作为范围）如果Target.Column = 13那么如果uCase（Target.Value）=“X”然后' – 在这里写你的拷贝代码可能忽略/删除第一个MsgBox“CopyThat！ 结束如果结束如果结束小组

只是一个build议…