Question

我需要我的审核清单（1）在当前行的末尾添加一个时间戳，然后（2）将行复制到另一个表，当有一个＆＃34; N＆＃34;或＆＃34; n＆＃34;在指定的列中标记。我们的想法是获得复制的不合规的摘要。

我的麻烦在于我使用的代码，它只能正确处理第一列。它对其他人没有任何作用。

我使用代码（如下）。

Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrHandler
    Application.EnableEvents = False

    If Target.Column = 9 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("I:I"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 2)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 2).Clear
                End If
            Next
        End If

    If Target.Column = 9 And UCase(Target) = "N" Then
    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)

    If Target.Column = 8 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("H:H"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 3)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 3).Clear
                End If
            Next
        End If
    If Target.Column = 8 And UCase(Target) = "N" Then
    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)

    If Target.Column = 7 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("G:G"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 4)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 4).Clear
                End If
            Next
        End If
    If Target.Column = 7 And UCase(Target) = "N" Then
    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)


    If Target.Column = 6 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("F:F"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 5)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 5).Clear
                End If
            Next
        End If
    If Target.Column = 6 And UCase(Target) = "N" Then
    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)

    If Target.Column = 5 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("E:E"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 6)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 6).Clear
                End If
            Next
        End If
    If Target.Column = 5 And UCase(Target) = "N" Then

    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)

    If Target.Column = 4 And UCase(Target) = "N" Then
        Set rChange = Intersect(Target, Range("D:D"))
        If Not rChange Is Nothing Then
            Application.EnableEvents = False
            For Each rCell In rChange
                If rCell > "" Then
                    With rCell.Offset(0, 7)
                        .Value = Now
                        .NumberFormat = "dd/mm/yyyy"
                    End With
                Else
                    rCell.Offset(0, 7).Clear
                End If
            Next
        End If
    If Target.Column = 4 And UCase(Target) = "N" Then
    Target.EntireRow.Copy Destination:=Sheet9.Range("A" & _
    Rows.Count).End(xlUp).Offset(1)

    End If
    End If
    End If
    End If
    End If
    End If
    End If

    End If
    End If
    End If
    End If
    End If

    ErrHandler:
    Application.EnableEvents = True

End Sub

Answer 1

如果缩进正确，很容易识别您的问题。

前两个问题：

请不要在您的日常工作中包含On Error GoTo ErrHandler。这只是意味着您忽略任何错误。您应该尝试识别可能产生错误的语句并修复导致这些错误的问题。
Target不一定是您的代码假设的单个单元格。例如，用户可以复制或清除范围。

以下是您的例程开始的缩进版本，删除了Then和Else个体，以便您可以看到问题。

Sub Worksheet_Change(ByVal Target As Range)

  If Target.Column = 9 And UCase(Target) = "N" Then
    If Not rChange Is Nothing Then
    End If

    ' We are already within If Target.Column = 9 And UCase(Target) = "N"
    ' So this If adds nothing
    If Target.Column = 9 And UCase(Target) = "N" Then

      ' We are within If Target.Column = 9 And UCase(Target) = "N"
      ' So the Then block of this If will never be executed 
      If Target.Column = 8 And UCase(Target) = "N" Then
        If Not rChange Is Nothing Then
        End If

      If Target.Column = 8 And UCase(Target) = "N" Then

        If Target.Column = 7 And UCase(Target) = "N" Then

您需要使用If .. ElseIf ... ElseIf ... Else ... End If构造

Sub Worksheet_Change(ByVal Target As Range)
  Application.EnableEvents = False

  If UCase(Target) = "N" Then

    If Target.Column = 9 Then
      If Not rChange Is Nothing Then
      End If

      ' Delete because unnecessary
      'If Target.Column = 9 Then

    ElseIf Target.Column = 8 Then
      If Not rChange Is Nothing Then
      End If

      ' Delete because unnecessary
      'If Target.Column = 8 Then

    ElseIf Target.Column = 7 Then
      If Not rChange Is Nothing Then
      End If

      ' Delete because unnecessary
      'If Target.Column = 7 Then

    ElseIf Target.Column = 6 Then

    : : : :

    End If

  End If

如果我理解您的代码，大多数重复都是不必要的。尝试我建议的更改。如果它们有效，我将向您展示如何更广泛地整理您的代码。

Answer 2

您似乎想要查看是否已将 N 键入或粘贴到D列中：由于目标的位置而导致的操作略有不同。许多行动都是一样的;基本上它们是K列中的时间戳并复制到Sheet9。 If/ElseIf/ElseIf/End If可以通过单独处理每个来为此工作，但您应该能够将所有相同的操作堆叠在一起。

Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("D:I")) Is Nothing Then
        On Error GoTo ErrHandler
        Application.EnableEvents = False
        Dim rChange As Range
        For Each rChange In Intersect(Target, Range("D:I"))
            If UCase(rChange.Value2) = "N" Then
                Cells(rChange.Row, "K") = Now
                Cells(rChange.Row, "K").NumberFormat = "dd/mm/yyyy"
                Cells(rChange.Row, "A").EntireRow.Copy _
                  Destination:=Sheet9.Cells(Rows.Count, "A").End(xlUp).Offset(1)
            ElseIf Not CBool(Len(rChange.Value)) Then
                Cells(rChange.Row, "K").ClearContents
            End If
        Next rChange
    End If

ErrHandler:
    Application.EnableEvents = True

End Sub

如果在D：I中键入或粘贴了 N ，则会将时间戳放入K列，并将该行复制到Sheet9。如果从D：I中删除该值，则删除时间戳并且不进行复制操作。通过使偏移量始终指向列K，您不需要为每列提供单独的例程。

如果满足某些条件，则将行加盖并复制到另一个工作表

2 个答案: