Question

我正在尝试在列F的单元格下拉列表“是”时复制不同工作表表单2中的Excel行，如果先前选择“是”，则“否”将删除该行。我还想检查工作表2中是否存在重复，然后用“是”，“否”按钮提示用户。如果“是”则重复，否则“否”不执行任何操作。

ColA:Customer Name  ColB:Customer Address   ColC:Customer City    ColD:Cust zip ColE:Tel     ColF:Yes/No

我试过这个。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lastrow As Long
If UCase(Range("F" & ActiveCell.Row).Value) <> "YES" Then Exit Sub

With ThisWorkbook.Worksheets("Sheet2")
    lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
          If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
        Range("A" & ActiveCell.Row).Value) > 0 Then Exit Sub
        Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
    If Response = vbNo Then Exit Sub

    .Range("A" & lastrow).Resize(, 5).Value = _
        Range("A" & ActiveCell.Row).Resize(, 5).Value
End With
Response = MsgBox("Record added")
End Sub

Answer 1

如果我理解正确，你需要这样的东西（代码仅在F列中更改的值时运行）：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastrow As Long
    Dim Response
    Dim rng As Range, rngToDel As Range
    Dim fAddr As String

    If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub

    Application.EnableEvents = False
    On Error GoTo ErrHandler

    With ThisWorkbook.Worksheets("Sheet2")
        lastrow = Application.Max(4, .Cells(.Rows.Count, "A").End(xlUp).Row + 1)

        If UCase(Target.Value) = "YES" Then

                Response = vbYes
                If WorksheetFunction.CountIf(.Range("A1:A" & lastrow), _
                    Range("A" & Target.Row).Value) > 0 Then
                    Response = MsgBox("Record already exists, add again?", vbQuestion + vbYesNo + 256)
                End If

                If Response = vbYes Then
                    .Range("A" & lastrow).Resize(, 5).Value = _
                        Range("A" & Target.Row).Resize(, 5).Value
                    MsgBox "Record added"
                End If

        ElseIf UCase(Target.Value) = "NO" Then
            With .Range("A4:A" & lastrow)
                Set rng = .Find(What:=Range("A" & Target.Row), _
                                                    LookIn:=xlValues, _
                                                    lookAt:=xlWhole, _
                                                    MatchCase:=False)
                If Not rng Is Nothing Then
                    fAddr = rng.Address
                    Do
                        If rngToDel Is Nothing Then
                            Set rngToDel = rng.Resize(, 5)
                        Else
                            Set rngToDel = Union(rngToDel, rng.Resize(, 5))
                        End If
                        Set rng = .FindNext(rng)
                        If rng Is Nothing Then Exit Do
                    Loop While fAddr <> rng.Address
                End If

                If Not rngToDel Is Nothing Then
                    rngToDel.Delete Shift:=xlUp
                    MsgBox "Records from sheet2 removed"
                End If
            End With
        End If
    End With


ExitHere:
    Application.EnableEvents = True
    Exit Sub
ErrHandler:
    Resume ExitHere
End Sub

当单元格下拉时，复制excel行在不同的工作表中＆＃34;是＆＃34;当＆＃34; No＆＃34;如果＆＃34;是＆＃34;删除该行之前被选中

1 个答案: