Date changes when Copied to New Workbook

[ROBINSYN]

I have a macro that on the click of a Shape, Creates a copy of original Timesheet to New Workbook , Pastes the values, renames it, clears the Original then the New Book Closes.

Problem is the dates when pasted change. The day and month remain intact but the year value reverts to 2000.

Please help.

CODE With Problem:
Sheets("TIMESHEET").Copy
Range("A1:O52").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.ScreenUpdating = False

CODE in it's Entirity:
Sub savecopy()
'
' savecopy Macro
' Macro recorded 10/24/2002 by Cindy Robinson

'FindLastRow()
ActiveSheet.Unprotect
Dim LastRow As Long
If WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

End If

ActiveSheet.Unprotect
Sheets("Timesheet").Select
Range("N3").Select
ActiveCell.FormulaR1C1 = "=MAX(c[12])+1"

Sheets("Summary").Range("A65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("N3")
Sheets("Summary").Range("B65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("B11")
Sheets("Summary").Range("C65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("A19")
Sheets("Summary").Range("D65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("J15")
Sheets("Summary").Range("E65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("B33")
Sheets("Summary").Range("F65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("B37")
Sheets("Summary").Range("G65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("M32")

Sheets("Timesheet").Range("z65536").End(xlUp).Offset(1, 0) = Sheets("Timesheet").Range("N3")
Application.ScreenUpdating = False
Sheets("TIMESHEET").Copy
Range("A1:O52").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False Application.ScreenUpdating = False

Range("N3").Select
ActiveCell.FormulaR1C1 = "=MAX(c[12])"
Application.ScreenUpdating = False

ActiveSheet.Shapes.SelectAll
Selection.Cut
Cells.Select
Rows("1:1").RowHeight = 4.5
Selection.Interior.ColorIndex = xlNone
Range("A1:O52").Select
Selection.Font.ColorIndex = 0



Application.ScreenUpdating = False



Range("A1").Select
' rename work


Target = Range("Q1")
' Get current path (empty if workbook has never been saved)
Path = ThisWorkbook.Path
' old line If Not Path = "" Then Path = Path & "\"
If Not Path = "" Then Path = Path & "\" ' new line
ThisFileNew = Path & Target & " .xls"
Resp = vbOK
' Check for existing file of same name and, if present, ask whether to overwrite
' old line If Dir(ThisWorkbook.Path & "\\" & Target & " .xls") <> "" Then
If Dir(ThisWorkbook.Path & "\" & Target & " .xls") <> "" Then ' new line
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If
' Save the workbook if file does not exist, or if user wants to overwrite it
If Resp = vbOK Then
ActiveWorkbook.SaveAs Filename:=ThisFileNew
Else
Resp = MsgBox("You will need to rename this file manually", vbInformation)
End If
ActiveWorkbook.Close
Application.ScreenUpdating = False



Range("D23:H29").Select
Selection.ClearContents

Range("K23:N29").Select
Selection.ClearContents

Range("B42:N45").Select
Selection.ClearContents

Range("B47:H48").Select
Selection.ClearContents

Range("I47:N48").Select
Selection.ClearContents

Range("K63").Select
ActiveCell.FormulaR1C1 = "1"

Range("V63").Select
ActiveCell.FormulaR1C1 = "1"

Range("X63").Select
ActiveCell.FormulaR1C1 = "1"


Sheets("Employees").Select

Range("A1").Select
ActiveCell.FormulaR1C1 = "1"

Sheets("Timesheet").Select
Range("A2").Select
Application.ScreenUpdating = False


Range("N3").Select
Selection.ClearContents
Application.ScreenUpdating = False
Range("G8").Select
Range("N3").Select
ActiveCell.FormulaR1C1 = "=MAX(c[12])+1"
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
End Sub

Thanks in Advance for any help

 

[Andrew Poulsom]

Are your dates the result of a formula, of which the year part is looking at a cell containing zero and recalculating when you copy the sheet?

If so set Calculation to manual before your copy the sheet, like this:

Application.Calculation = xlManual

You can set it back to Automatic after your PasteSpecial, like this:

Application.Calculation = xlAutomatic

 

[ROBINSYN]

The date is a result of vlookup in a drop down menu.

The cell underneath is set to the same lookup so it will print with the timesheet.

Then there are 14 cells that use the date value from the vlookup as the abosulte value -1, -2, etc. to calculate a two week time period.

Where would I place the the code for manual calculation.

I tried right before copy then after but I still get the same result.

Thanks

 

[Andrew Poulsom]

Possibly put it before:

Sheets("TIMESHEET").Copy

You can debug your code by putting a break point after that line and examining what is in the copied sheet. I might be wrong about the calculation thing, but I can't think of another reason for the year changing to 2000.

 

[ROBINSYN]

Solved with thanks

Solved with thanks

:P