Loop until won't stop!?

I've fixed my previous problem, and this formula works except for one thing!

it doesnt stop at the last empty cell it continues to create a new sheet but is unable to name it as ther is nothing in the cell from whihc it takes its name.

why? what have i missed?

thanks

 Sub Macro1()
'
' Macro1 Macro
' Macro recorded 26/07/2007 by Michael Skinner
'
Application.ScreenUpdating = False
Sheets("export").Select
Range("Ar2").Select

Do Until IsEmpty(ActiveCell)

For n = 1 To 100
Dim sSheetName As String
sSheetName = (ActiveCell)

    Sheets("Template").Select
    Sheets("Template").Copy After:=Sheets(1)
    
    Sheets("Template (2)").Select
    Sheets("Template (2)").Name = sSheetName
    
    Sheets("export").Select
    Range("A1").Select
    ActiveCell.Offset(n, 0).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(sSheetName).Select
    Range("E2:AA2").Select
    ActiveSheet.Paste
    
   
    Sheets("export").Select
    Range("b1").Select
    ActiveCell.Offset(n, 0).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(sSheetName).Select
    Range("h10").Select
    ActiveSheet.Paste
    
    Sheets("export").Select
    Range("c1").Select
    ActiveCell.Offset(n, 0).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(sSheetName).Select
    Range("H11").Select
    ActiveSheet.Paste
    
    Sheets("export").Select
    Range("d1").Select
    ActiveCell.Offset(n, 0).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(sSheetName).Select
    Range("E6").Select
    ActiveSheet.Paste

    Sheets("export").Select
    Range("at1").Select
    ActiveCell.Offset(n, 0).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets(sSheetName).Select
    Range("e38").Select
    ActiveSheet.Paste
    
Sheets("export").Select
Range("Ar2").Select
ActiveCell.Offset(n, 0).Select

Next n

      
Loop
End Sub