VBA creates named ranges, but named ranges disappear

Hi All

You've all been exceptionally helpful in the past and I hope to whatever gods there are that you can help me again....

I've created a spreadsheet for our Human Resources department to track how long it takes a new employment position to be filled, from start to finish.

I use data validation in the Tracking table for ease of use for the enduser, and I use named ranges to reference in the data validation.

I’m creating a macro that allows the user (at the click of a button) to create new tabs for the new year.

Almost everything works, but when I specify the named range to use for data validation (both in Excel and in VBA), the named ranges do not exist. To make it even more confusing (to me), after naming the ranges or running the macro (thus creating 2 new tabs), the named ranges exist only when selecting the last tab (named “Table” & year).

Because the named ranges don’t exist (apparently), I cannot use data validation with the new named ranges.

Why do the named ranges only show up when the tab in which they reside is selected?

I've included the code below and attached a sample worksheet.

Sub MakeNewTabs()

Dim iReply As Long

iReply = Application.InputBox(Prompt:="Which year would you like to add?", _
                 Title:="CREATE TABS", Type:=1)
    
If IsNumeric(iReply) And iReply < 2100 And iReply > Year(Now) Then
   
    Sheets(1).Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "Position Tracking " & iReply
    Sheets(2).Copy After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = "Table " & iReply
   
Else    'They cancelled (VbCancel)

    Exit Sub

End If

With Worksheets("Table " & iReply)
    .Names.Add Name:="TypeOfFill" & iReply, RefersTo:=.ListObjects(1).ListColumns(1).DataBodyRange
    .Names.Add Name:="Divisions" & iReply, RefersTo:=.ListObjects(2).ListColumns(1).DataBodyRange
    .Names.Add Name:="Phases" & iReply, RefersTo:=.ListObjects(3).ListColumns(1).DataBodyRange
    .Names.Add Name:="Auditors" & iReply, RefersTo:=.ListObjects(4).ListColumns(1).DataBodyRange
    .Names.Add Name:="Recruiters" & iReply, RefersTo:=.ListObjects(5).ListColumns(1).DataBodyRange
    .Names.Add Name:="AuditReq" & iReply, RefersTo:=.ListObjects(6).ListColumns(1).DataBodyRange
    .Names.Add Name:="ReqStatus" & iReply, RefersTo:=.ListObjects(7).ListColumns(1).DataBodyRange
    
End With


With Worksheets("Position Tracking " & iReply)
    .ListObjects(1).Name = "Tracking" & iReply
    .ListObjects(2).Name = "Quarterly" & iReply
    With .ListObjects(1)
    For x = 1 To 22
        .ListColumns(x).DataBodyRange.ClearContents
        .ListColumns(x).DataBodyRange.ClearComments
        .ListColumns(x).DataBodyRange.Validation.Delete
    Next x
    For x = .ListRows.Count To 3 Step -1
        .ListRows(x).Delete
    Next x
        .ListColumns(1).DataBodyRange.Validation.Add Type:=x1ValidateList, _
            AlertStyle:=x1ValidAlertStop, Operator:=x1Between, _
            Formula1:="=Divisions" & iReply
        
    End With
        
End With

With Worksheets("Table " & iReply)
    .Cells.Replace What:="Tracking2014", Replacement:="Tracking" & iReply, LookAt:=xlPart, MatchCase:=False
End With


End Sub

Thanks in advance for the help!
BrotherNeptune