Para Luis Mondelo necesito ayuda con este procedimiento

Estoy tratando de realizar la macro que me cambie los nombres de rangos, la cual tu me diste y funciona perfecto. Que es esta:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$B$4" Then
        ruta = rD
        numer = 1
            ActiveWorkbook.Names(ruta).Delete
            nuevo = Cells(3 + numer, 2).Value
            Range(Cells(4, 3 + numer), Cells(200, 3 + numer)).Name = nuevo
                ruta = nuevo
                rD = ruta        
 End If
End Sub

Pero al usar esta como subrutina no me funciona y no se porque razón, no hace nada, lo brinca como si fuera error la primera instrucción de la subrutina ( rango); así la escribí:

Public rD
Public ruta
Public numer
--------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$B$4" Then
        ruta = rD
        numer = 1
            call rango           
End If
End Sub
-----------------------------------------------------------------
Sub rango()
        ActiveWorkbook.Names(ruta).Delete
        nuevo = Cells(3 + numer, 2).Value
        Range(Cells(4, 3 + numer), Cells(200, 3 + numer)).Name = nuevo
        ruta = nuevo
        rD = ruta
End Sub

Esto la quiero usar así porque necesito varios rangos.

Si puedes ayudarme con este problema te lo agradecería al máximo.

Muchas Gracias