问题
I need my audit list to (1) add a time stamp in the end of current line and then (2) copy the line to the other sheet, when there is a "N" or "n" marked in the specified column. The idea is to get a summary of copied non-conformities.
My trouble is that in the case of the code I use, it only deals with the first column correctly. It does nothing with others.
I use the code (below).
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
回答1:
Your problem is easy to identify if you indent correctly.
First two other issues:
- Pleae do not include
On Error GoTo ErrHandlerat the top of your routine. This just means you ignore any errors. You should be trying to identify statements that can give errors and to fix the problems that cause those errors. Targetdoes not have to be a single cell as your code assumes. For example, the user could have copied or cleared a range.
Below is an indented version of the start of your routine with the Then and Else bodies removed so you can see the problem.
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
You need to use the If .. ElseIf ... ElseIf ... Else ... End If construct
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
If I understand your code, most of the duplication is unnecessary. Try the changes I have suggested. If they work, I will show you how to tidy your code more extensively.
回答2:
It seems that you want to see if an N has been typed or pasted into column D:I with slightly varying actions resulting from the location of Target. Many of the actions are the same; essentially they timestamp in column K and copy across to Sheet9. An If/ElseIf/ElseIf/End If would work for this by dealing with each individually but you should be able to stack all of the same actions together.
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
If an N is typed or pasted in D:I, a timestamp is put into column K and the row is copied to Sheet9. If the value is deleted from D:I, the timestamp is removed and no copy operation is made. By making the offset always point to column K, you do not require individual routines for each column.
来源：https://stackoverflow.com/questions/29701395/timestamping-and-copying-a-line-to-another-sheet-if-certain-condition-met