renaming macro fail

Hi all,

I am trying to create a macro that copies selected tabs and renames them depending on cell contents.

I have the following code that works the first time i run it. However if i try and run it again and try to create a third set of tabs it fails.

The macro currently allows the first set of tabs to be renamed depending on the contents of cell D15 and the new tabs on the contents of D16

Any ideas. Thanks

Option Explicit

Sub NewCompany()

Dim MyArray As Variant
Dim i As Long
Dim strName1 As String
Dim strName2 As String

MyArray = Array("Assumptions", "Yearly", "Monthly", "Sales Calc", _
"Sales and COS", "FAs 1", "Loan", "HP 1")

strName1 = Sheets("Overview").Range("D15")
strName2 = Sheets("Overview").Range("D16")

For i = 0 To UBound(MyArray)
Sheets(MyArray(i)).Copy After:=Sheets(4 + i)
ActiveSheet.Name = MyArray(i) & " " & strName2
Worksheets(MyArray(i)).Name = MyArray(i) & " " & strName1
Next i

ActiveWindow.ScrollWorkbookTabs Position:=xlFirst

Application.DisplayAlerts = False
Sheets("TOC").Delete
Application.DisplayAlerts = True

Application.Run "'" & ActiveWorkbook.Name & "'!CreateTOC"

End Sub