Thanks it works perfect at new empty workbook ,but in my workbook I am getting error 424 object required
This is the code at entire worksheet with your code. Can you please check what is going wrong?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim srow As Double
If Left(Target.Address, 2) = "$Q" Then
srow = Target.Row
[V40].Value = Cells(srow, 17)
[W40].Value = Cells(srow, 2)
[Y40].Value = Cells(srow, 3)
[W41].Value = Cells(srow, 7)
[Y41].Value = Cells(srow, 13)
[V43].Value = Cells(srow, 8)
[X43].Value = Cells(srow, 6)
[V45].Value = Cells(srow, 4)
[X45].Value = Cells(srow, 5)
[X47].Value = Cells(srow, 16)
[X49].Value = Cells(srow, 9)
[W51].Value = Cells(srow, 20)
[X51].Value = Cells(srow, 11)
[V55].Value = Cells(srow, 17)
[W55].Value = Cells(srow, 2)
[Y55].Value = Cells(srow, 3)
[W56].Value = Cells(srow, 7)
[Y56].Value = Cells(srow, 13)
[X58].Value = Cells(srow, 16)
[W67].Value = Cells(srow, 20)
[V60].Value = Cells(srow, 4)
[W60].Value = Cells(srow, 11)
If Left(Target.Value, 3) = "DOR" Then
Cells(Target.Row, 21).FormulaR1C1 = "=ifNA(MATCH(RC[-4],'BAYS '!R6,0),0)"
srow = Cells(Target.Row, 21).Value
Cells(Target.Row, 21).Value = ""
Sheets("BAYS ").Cells(9, srow).Value = Cells(Target.Row, 7)
Sheets("BAYS ").Cells(7, srow).Value = Cells(Target.Row, 19)
Sheets("BAYS ").Cells(8, srow).Value = Cells(Target.Row, 16)
ElseIf Left(Target.Value, 3) = "PAD" Then
Cells(Target.Row, 21).FormulaR1C1 = "=ifNA(MATCH(RC[-4],'BAYS '!R15,0),0)"
srow = Cells(Target.Row, 21).Value
Sheets("BAYS ").Cells(16, srow).Value = Cells(Target.Row, 20)
Sheets("BAYS ").Cells(17, srow).Value = Cells(Target.Row, 19)
End If
End If
On Error Resume Next
If Target.Column = 1 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 16).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 4 Then
Cancel = True
Set CopyCell = Target
End If
If Not Intersect(Target, Range("P4:P201,R4:R201")) Is Nothing Then
Cancel = True
Target.Formula = Now()
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not CopyCell Is Nothing Then
If Not Intersect(ActiveCell, Range("V61:V66, X60:X66")) Is Nothing Then
ActiveCell.Value = CopyCell.Value
Range("W" & ActiveCell.Row).Value = CopyCell.Offset(, 7).Value
Set CopyCell = Nothing
End If
End If
End Sub
Sub Clearcells()
'Updateby Extendoffice 20161008
Range("D4", "D201").ClearContents
Range("E4", "E201").ClearContents
Range("F4", "F201").ClearContents
Range("I4", "I201").ClearContents
Range("J4", "J201").ClearContents
Range("K4", "K201").ClearContents
Range("L4", "L201").ClearContents
Range("M4", "M201").ClearContents
Range("N4", "N201").ClearContents
Range("O4", "O201").ClearContents
End Sub
Sub AreYouSure()
Dim Sure As Integer
Sure = MsgBox("Are you sure?", vbOKCancel)
If Sure = 1 Then Call Clearcells
End Sub
Sub Clearlabels()
'Updateby Extendoffice 20161008
Range("V40,W40,Y40,W41,Y41,V43,X43,V45,X45,X47,X49,W51,X51,V55,W55,Y55,W56,Y56,X58,W67,W67").ClearContents
Range("V60", "V66").ClearContents
Range("W60", "W66").ClearContents
Range("X60", "X66").ClearContents
Range("Y60", "Y66").ClearContents
End Sub
Sub PrintLabel()
Range("Print1").PrintPreview
End Sub
Sub PrintMultilabel()
Range("Print2").PrintPreview
End Sub