Question

我有一个工作簿，其中特定的订单项由工作人员完成，一旦完成，它们将被检查完成。这会触发复选框左侧的行/范围，以便选择，复制并粘贴到第一个可用行的下一个工作表中。然后从第一个工作表中清除当前行。每个工作表都有预先填写并预先链接到单元格的复选框。我遇到的问题是，当选中该复选框时，runall宏会在当前选中的行上激活，而不是复选框所在的行，并且链接到该单元格。例如，如果复选框在行M2中，但当前选择的单元格是B8，宏将尝试复制并粘贴第8行而不是预期的第2行。由于没有撤消宏，这会导致严重的问题。任何帮助将不胜感激！

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

还有很多其他方法可以实现这一点而不是复选框......我想到的一个“更干净”的方法是使用工作表的Change事件。

摆脱复选框
将列M的标题设置为“已完成= X”
在表格对象中使用此代码：

Private Sub Worksheet_Change（ByVal Target As Range）如果Target.Column = 13那么如果uCase（Target.Value）=“X”那么 ' - 在这里写你的拷贝码可能先忽略/删除x MsgBox“CopyThat！” 万一万一 End Sub

只是一个建议......

复选框在选定的单元格行上运行宏;需要它们在链接的单元格行

1 个答案: