Process filename extension

I had this question after viewing Named range not carried over.

The filename extension that is created for each file created when this macro runs is left off if the filename has a period elsewhere in the name.  Assistance in correcting this minor problem is greatly appreciated.

Sub Separate_by_Filename_Column_Into_Separate_Workbooks()

'This routine will separate the active sheet into separate workbook files
'based on the filename given in the filename column.
'If this workbook contains a sheet (tab) named "Validate" with named ranges for validation,
'and with validation columns in the original sheet, it should keep the named ranges,
'and the validation columns, as well as the name of the originating sheet.


Dim aFiles As Variant

strDirectory = GetFolder(ActiveWorkbook.path)
If strDirectory = "" Then Exit Sub
Set origSh = ActiveSheet
Set rngFound = Nothing
On Error Resume Next
Set rngFound = Range("1:1").Find("Filename")
On Error GoTo 0
If Not rngFound Is Nothing Then
    strCol = Split(rngFound.Address, "$")(1)
    Set myRange = Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp))
    ActiveWorkbook.Sheets.Add
    myRange.Copy ActiveSheet.Range("A1")
    Application.DisplayAlerts = False
    Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
    aFiles = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    For Each C In aFiles
        origSh.Copy
        Set newWbk = ActiveWorkbook
        Set newSh = newWbk.ActiveSheet
        Set myNewRange = Range(Range(strCol & "1"), Range(strCol & Rows.Count).End(xlUp))
        myNewRange.AutoFilter Field:=rngFound.Column, Criteria1:="<>" & C, VisibleDropDown:=True
        Set origRng = Nothing
        On Error Resume Next
        Set origRng = newSh.Range(Range(strCol & "2"), Range(strCol & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow
        On Error GoTo 0
        If Not origRng Is Nothing Then
            ActiveSheet.ShowAllData
            For Each ar In origRng.Areas
                ar.Delete
            Next
        End If
        origSh.Parent.Sheets("Validate").Copy after:=newSh
        newWbk.Sheets("Validate").Visible = xlSheetHidden
        newSh.Activate
        newSh.Name = Left(C, 31)
        newSh.Range("A2").Activate
        newWbk.SaveAs strDirectory & "\" & C
        newWbk.Close False
    Next
End If
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Select allOpen in new window