Problem using macro to add sheets

Right now I am using a macro to add sheets to my workbook. I have a worksheet with this code in it,

 Private Sub Worksheet_Change(ByVal Target As Range)
' CopyMarketTabs Macro
' Macro créée le 02/08/2006 par DUHAMEAUT
Dim strTab As String, strCol1 As String, strCol2 As String, strcol3 As String, strCol4 As String, lgInitRow As Long
Dim lgRow As Long, shtSht, strShtName As String, strShtTemplate As String, strDesc As String
 
'have the list on a worksheet called Ref, starting at cell A1
 If Intersect(Target, Me.Range("A1:A65536")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
If Target.Value <> "" Then strCol1 = Target.Value Else Exit Sub
If Err = 13 Then
Exit Sub
End If
 
strShtTemplate = "TEMPLATE" 'CHANGE HERE
 
'check for existing tab names
 
For Each shtSht In ActiveWorkbook.Sheets
   
    If shtSht.Name = strCol1 Then
        MsgBox "Sheet " & strCol1 & " exists already"
        Exit Sub
    End If
   
Next shtSht
 
    Sheets(strShtTemplate).Copy before:=Sheets(4)
   
    With ActiveSheet 'adjust the fields to match the columns in your list
        .Name = strCol1
        .Cells(1, 1).FormulaR1C1 = strCol1 'CHANGE HERE
    End With
 
 
Application.ScreenUpdating = True
 
End Sub



So right now, when I type a word into the A1 cell of this worksheet, a new worksheet is created from my Template worksheet and the name of the worksheet is what I typed into cell A1. This works perfectly up until about the 40th worksheet, and then it will not add anymore worksheets. Is there a way to fix this problem, using this code,

Thanks for youre advice, Greg.