Create the same named Range across multiple sheets

Hi All Expert,

I have been given a task to update data validation across multiple cells & worksheets. It working fine but I am really surprised why the named range only been created at the last worksheets. Based on the code, the named range "ScoreDecimal" supposed to be created in each sheets.

It the user remove the last worksheets, the updated data will gone

Sub test()
Dim ws As Worksheet
Dim i As Integer

    For Each ws In Sheets
    
        Application.StatusBar = "Sheets Name: " & ws.Name & "     Sheets number: " & ws.Index & "    out of Total: " & Sheets.Count
    
        On Error Resume Next
        ws.Unprotect "sb"
        ws.Unprotect "SB"
        On Error GoTo 0
           
            For i = 0 To 8
                ws.Cells(502, "R").Offset(i).Value = 1 + i / 2
            Next i
            
            ws.Range("R502:R510").Name = "ScoreDecimal"
            ws.Range("C504").Value = "ScoreDecimal"
                        
        With ws.Range("H20").SpecialCells(xlCellTypeSameValidation).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=INDIRECT($C$504)"
            .IgnoreBlank = False
            .InCellDropdown = True
            .InputTitle = "DATA ENTRY GUIDE:"
            .ErrorTitle = "WRONG VALUE ENTERED"
            .InputMessage = "" & Chr(10) & "Assessment scores must be in absolute number between 1 to 5"
            .ErrorMessage = "Assessment scores must be between 1 to 5"
            .ShowInput = True
            .ShowError = True
        End With
        
        ws.Protect "sb"
    Next ws
    
    MsgBox "Completed", 64, "Job Done"
End Sub