Problema em Macro - Criar nova planilha, Nomear, e copiar nome

Bom dia,

Sou iniciante em VBA, por isso a solução pode ser simples, mas não estou enchergando!

Estou usando a MACRO abaixo para gerar uma nova planilha e automaticamente nomea-la por uma sequencia númerica.
Assim também possue um comando que copia para a Cel "I4" o nome da planilha.

Meu problema é que quando executo a macro, ela esta colando o nome de todas as planilhas nas suas respectivas Celulas I4! (não teria problema se não possuisse outras planilhas além das que estou copiando!

Como resolver???

Sub SheetCopy()
'
' SheetCopy Macro
'
' Atalho do teclado: Ctrl+Shift+N
'
Dim Sh As Worksheet, TemplateSh As Worksheet
Dim ShNum As Integer, HighestNum As Integer
Dim SheetCoreName As String


' INDICATE THE CORE SHEET NAME
SheetCoreName = " "

' INDICATE THE SOURCE SHEET
Set TemplateSh = Sheets("NOVA PLANILHA")


' DETERMINE NEXT NUMBER FOR SHEET
For Each Sh In Worksheets
If InStr(1, Sh.Name, SheetCoreName) = 1 Then
   ShNum = Val(Right(Sh.Name, Len(Sh.Name) - Len(SheetCoreName)))
   If ShNum > HighestNum Then HighestNum = ShNum
End If
Next Sh

' COPY TEMPLATE
TemplateSh.Copy after:=Sheets(Sheets.Count)

' MAKE VISIBLE
ActiveSheet.Visible = xlSheetVisible

' RENAME
ActiveSheet.Name = SheetCoreName & HighestNum + 1

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
   ws.Range("I4") = ws.Name
Next


End Sub

Bom dia!!

Eu não sei se entendi, mas tente isso.

Código:

    
    For i = 1 To Sheets.Count
        Cells(i, 9) = Sheets(i).Name
    Next i

Att