Moving Sheet from one Workbook to another multiple times.

Hey guys,

Having kind of a strange problem. Basically, what I am trying to do is copy a sheet from one workbook "Call Register" into another workbook" Call Register Archive", rename the sheet and save and close the archive then print the original sheet and erase all the data on the sheet in "Call Register". I have a code that is working perfectly on the first attempt (archive workbook only has (sheet1) in it). However, when I try to run the macro a second time (after a sheet has already been pasted) it freezes just after copying the sheet to the archive and doesn't complete the process of renaming the sheet and saving/closing the archive book.

Here is my code:

Private Sub CommandButton1_Click()
Workbooks("Call Register.xlsm").Activate
ActiveWorkbook.Sheets("Lab Tracker").Copy After:=ActiveWorkbook.Sheets("Lab Tracker")

Workbooks.Open "C:\Documents\Call Register Archive.xlsm"

Dim My2 As Workbook, Sh1 As Worksheet
Set Sh1 = ThisWorkbook.ActiveSheet
Set My2 = Workbooks("Call Register Archive.xlsm")

Sh1.Move After:=My2.Sheets(My2.Sheets.Count)
ActiveSheet.Name = [D3]
    
Workbooks("Call Register Archive.xlsm").Activate
ActiveWorkbook.Close SaveChanges:=True


Workbooks("Call Register.xlsm").Activate
ActiveSheet.PrintOut from:=1, To:=1

Dim Rng1 As Range
Dim Rng2 As Range
Dim Rng3 As Range
Dim Rng4 As Range
Dim Rng5 As Range
Dim Rng6 As Range
Dim Rng7 As Range
Dim Rng8 As Range
Dim Rng9 As Range
Dim Rng10 As Range
Dim Rng11 As Range
Dim Rng12 As Range
Dim Rng13 As Range
Dim Rng14 As Range
Dim Rng15 As Range
Dim Rng16 As Range
Dim Rng17 As Range
Dim Rng18 As Range
Dim Rng19 As Range
Dim Rng20 As Range
Dim Rng21 As Range
Dim Rng22 As Range
Dim Rng23 As Range
Dim Rng24 As Range

Set Rng1 = Sheets("Lab Tracker").Range("B8:F8")
Set Rng2 = Sheets("Lab Tracker").Range("B9:F9")
Set Rng3 = Sheets("Lab Tracker").Range("B10:F10")
Set Rng4 = Sheets("Lab Tracker").Range("B11:F11")
Set Rng5 = Sheets("Lab Tracker").Range("B12:F12")
Set Rng6 = Sheets("Lab Tracker").Range("B13:F13")
Set Rng7 = Sheets("Lab Tracker").Range("B14:F14")
Set Rng8 = Sheets("Lab Tracker").Range("B15:F15")
Set Rng9 = Sheets("Lab Tracker").Range("B16:F16")
Set Rng10 = Sheets("Lab Tracker").Range("B17:F17")
Set Rng11 = Sheets("Lab Tracker").Range("B18:F18")
Set Rng12 = Sheets("Lab Tracker").Range("B19:F19")
Set Rng13 = Sheets("Lab Tracker").Range("B20:F20")
Set Rng14 = Sheets("Lab Tracker").Range("B21:F21")
Set Rng15 = Sheets("Lab Tracker").Range("B22:F22")
Set Rng16 = Sheets("Lab Tracker").Range("B23:F23")
Set Rng17 = Sheets("Lab Tracker").Range("B24:F24")
Set Rng18 = Sheets("Lab Tracker").Range("B25:F25")
Set Rng19 = Sheets("Lab Tracker").Range("B26:F26")
Set Rng20 = Sheets("Lab Tracker").Range("B27:F27")
Set Rng21 = Sheets("Lab Tracker").Range("B28:F28")
Set Rng22 = Sheets("Lab Tracker").Range("B29:F29")
Set Rng23 = Sheets("Lab Tracker").Range("B30:F30")
Set Rng24 = Sheets("Lab Tracker").Range("D3")


Rng1.ClearContents
Rng2.ClearContents
Rng3.ClearContents
Rng4.ClearContents
Rng5.ClearContents
Rng6.ClearContents
Rng7.ClearContents
Rng8.ClearContents
Rng9.ClearContents
Rng10.ClearContents
Rng11.ClearContents
Rng12.ClearContents
Rng13.ClearContents
Rng14.ClearContents
Rng15.ClearContents
Rng16.ClearContents
Rng17.ClearContents
Rng18.ClearContents
Rng19.ClearContents
Rng20.ClearContents
Rng21.ClearContents
Rng22.ClearContents
Rng23.ClearContents
Rng24.ClearContents

End Sub

Like I said, it works perfectly as long as the "Call Register Archive" workbook hasn't already had a sheet moved into from the "Call Register". That kind of defeats the purpose of it being an arhive if it only works once. Any ideas? Also attached an example of my Call Register Workbook so you can see what I'm talking about. Just create a blank workbook in documents called "Call Register Archive".