Copy a range of information to a worksheet in a specific file

[Theo Degr]

Below is some code that was created with the help of this sight as well as
some reference books. The code works wonders for what I want it to do but I
would like to improve upon it. Currently I print my worksheet, Copy it to a
new worksheet, Save the Work Sheet use a cell location for the name of the
file, and then it clears the worksheet. What I would like to improve with
this code would be to have it copy the information to another file located in
another directory (example C:\"Original Directory" to c:\"New Directory"
Could someone offer me a suggestion as to how to accomplish this. The code is
posted below. Thanks
Sub All_in_One()

' Prints the Time Sheet
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

' Copies the Time Sheet to the Time Record Tab
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rng1 As Range, rng2 As Range
Set sh1 = Worksheets("Time Sheet")
Set sh2 = Worksheets("Time Record")
Set rng1 = sh1.Range("a11:AE26")
Set rng2 = GetRealLastCell(sh2)
Set rng2 = sh2.Cells(rng2.Row + 1, 1)
rng1.Copy
rng2.PasteSpecial xlValues

' Clears the Time Sheet
Range("C1216").Select
Selection.ClearContents
Range("F12:O16").Select
Selection.ClearContents
Range("C2125").Select
Selection.ClearContents
Range("F21:O25").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-9
Range("F1").Select

' Saves the Time Sheet to a new File Naming it by the Employees Name

Dim CurrentWorkbook As Workbook
Dim NewWorkbook As Workbook
Dim Rng As Range

Set CurrentWorkbook = ActiveWorkbook
Set NewWorkbook = Workbooks.Open(Filename:="Time.xls")
CurrentWorkbook.Sheets(Array("Time Sheet")).Copy
after:=NewWorkbook.Worksheets(1)
Set Rng = Sheets("Time Sheet").Range("b5")
ActiveWorkbook.SaveAs _
Filename:=Rng.Value & ".xls", _
FileFormat:=xlWorkbookNormal
NewWorkbook.Close savechanges:=False
CurrentWorkbook.Close savechanges:=False





End Sub

Public Function GetRealLastCell(sh As Worksheet) As Range
Dim RealLastRow As Long
Dim RealLastColumn As Long
On Error Resume Next
RealLastRow = _
sh.Cells.Find("*", sh.Range("a1"), , , xlByRows, xlPrevious).Row
RealLastColumn = _
sh.Cells.Find("*", sh.Range("a1"), , , xlByColumns, xlPrevious).Column
If RealLastRow < 1 Then RealLastRow = 1
If RealLastColumn < 1 Then RealLastColumn = 1
Set GetRealLastCell = sh.Cells(RealLastRow, RealLastColumn)
End Function

 

[Tom Ogilvy]

ActiveWorkbook.SaveAs _
Filename:=Rng.Value & ".xls", _
FileFormat:=xlWorkbookNormal

would become

newWorkbook.SaveAs _
Filename:="C:\New Directory\" &Rng.Value & ".xls", _
FileFormat:=xlWorkbookNormal


assuming "C:\New Directory" already exists.