Automatically naming a range on each sheet in VBA

I am using the following VBA to create a unique sheet for each record within my workbook what I am also wanting to do however is take the unique name each sheet has for example AU000000RMP0 and define column D as this named range so I can use it for a running total on my master sheet. My last piece of code at the bottom of my VBA entitled 'testing auto added named ranges is as far as I got...

Sub MakeSheets()
'
' MakeSheets Macro
'

' Makes seperate worksheet for individual values

Sheets("TRACS STCK REC NEW").Select

Dim rLNColumn As Range
Dim rCell As Range
Dim sh As Worksheet
Dim shDest As Worksheet
Dim rNext As Range

Const sLNHEADER As String = "Security ID"

Set sh = ThisWorkbook.Sheets("COMPILER")
Set rLNColumn = sh.UsedRange.Find(sLNHEADER, , xlValues, xlWhole)

'Make sure you found something
If Not rLNColumn Is Nothing Then
'Go through each cell in the column
For Each rCell In Intersect(rLNColumn.EntireColumn, sh.UsedRange).Cells
'skip the header and empty cells
If Not IsEmpty(rCell.Value) And rCell.Address <> rLNColumn.Address Then
'see if a sheet already exists
On Error Resume Next
Set shDest = sh.Parent.Sheets(rCell.Value)
On Error GoTo 0

'if it doesn't exist, make it
If shDest Is Nothing Then
Set shDest = sh.Parent.Worksheets.Add
shDest.Name = rCell.Value
End If

'Find the next available row
Set rNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)

'Copy and paste
Intersect(rCell.EntireRow, sh.UsedRange).Copy rNext



'Testing auto adding named ranges


Columns("D:D").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:=shDest





Thanks in advance guys!!!