VBA Code doesnt break links to the new worksheet

[DharmaK]

Sub CopyInNewWB()

Dim wbN As Workbook
Dim xSht As Worksheet, xNSht As Worksheet
Dim i As Long, xCName As Long
Dim dic As Object, ky As Variant, lnk As Variant
Dim xTitle As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Set xSht = ThisWorkbook.Sheets("Template")
Set dic = CreateObject("Scripting.Dictionary")

xCName = 2 'Change this number to the column number which you will create new sheets based on
xTitle = "A:J"

For i = 2 To xSht.Cells(Rows.Count, xCName).End(xlUp).Row
If xSht.Cells(i, xCName).Value <> "" Then dic(xSht.Cells(i, xCName).Value) = xSht.Cells(i, "A").Value
Next

For Each ky In dic.keys
ThisWorkbook.Sheets("CoverPage").Copy
Set wbN = ActiveWorkbook
xSht.Range(xTitle).AutoFilter xCName, ky
Set xNSht = Worksheets.Add(, wbN.Sheets(wbN.Sheets.Count))
xNSht.Name = ky
ActiveWindow.DisplayGridlines = False
xSht.AutoFilter.Range.EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit

'save workbook
wbN.SaveAs ThisWorkbook.Path & "\" & dic(ky) & " - " & ky
wbN.Close False

Next

On Error Resume Next
With ActiveWorkbook
For Each lnk In .LinkSources(Type:=xlLinkTypeExcelLinks)
.BreakLink Name:=lnk, Type:=xlLinkTypeExcelLinks

Next
End With
On Error GoTo 0
xSht.AutoFilterMode = False


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub