Kurt Smart
Member
Hi,
Can anyone help edit this code...
What id like is this... If selection is 'Completed' check if cell in column 'U' is 'Y' and cell in column 'V' is 'Y'.... if they are true allow the rest of the code to run. If there is no 'Y' in either column the transfer can go ahead, if only a Y in U then popup to ask for the Y before going ahead.
I hope this makes sense its boggling my mind
Can anyone help edit this code...
What id like is this... If selection is 'Completed' check if cell in column 'U' is 'Y' and cell in column 'V' is 'Y'.... if they are true allow the rest of the code to run. If there is no 'Y' in either column the transfer can go ahead, if only a Y in U then popup to ask for the Y before going ahead.
I hope this makes sense its boggling my mind
Code:
ay = Target.Row
ax = Target.Column
tv = Target.Value
If ax = 21 And ay > 1 And tv <> Empty And tv <> ActiveSheet.Name And ActiveSheet.Cells(ay, 1) <> Empty And (tv = "Issues" Or tv = "Completed") Then
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
R = 1
With Sheets(tv)
Do
R = R + 1
Loop Until .Cells(R + 1, 1) = Empty
R = R + 1
End With
If tv = "Completed" Then Sheets(tv).Unprotect "KPS"
DOP = False
With ActiveSheet
If .ProtectContents Then
.Unprotect "KPS"
DOP = True
End If
.Range("A" & ay & ":U" & ay).Copy
Sheets(tv).Range("A" & R).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
If Err.Number = 0 Then
.Range("A" & ay & ":U" & ay).Delete shift:=xlUp
Else
MsgBox "Couldn't Move That Row To " & tv & "!"
End If
If DOP Then .Protect "KPS", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
End With
If tv = "Completed" Then Sheets(tv).Protect "KPS", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
Sheets("In Progress").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Last edited: