Sub extraccion_nombre()
Dim X, Nombre As String
Dim i As Integer
'//////////////////////////////////////////////////
' detiene momentaneamente los mensajes de Excel
'//////////////////////////////////////////////////
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'//////////////////////////////////////////////////
' añade la hoja ZonasConNOmbre en primer lugar
' y elimina la que existe
'//////////////////////////////////////////////////
If Sheets(1).Name = "ZonasConNombres" Then Sheets("ZonasConNombres").Delete
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "ZonasConNombres"
    Sheets("ZonasConNombres").Move Before:=Sheets(1)
'//////////////////////////////////////////////////
' fondo de la hoja ZonasConNombres
'//////////////////////////////////////////////////
Cells.Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -9.99786370433668E-02
        .PatternTintAndShade = 0
    End With
'//////////////////////////////////////////////////
' Título de la hoja ZonasConNombres
'//////////////////////////////////////////////////
Range("B2:H2").Select
    ActiveCell.FormulaR1C1 = "lista de las zonas con nombre"
    Range("B2:H2").Select
    Range("C2").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'//////////////////////////////////////////////////
' llama en B y C a las zonas con nombre y al rango correspondiente
' prévisto para 100 nombres máximo
'//////////////////////////////////////////////////
    Range("B4").Select
    Selection.ListNames
    For i = 1 To 100
        Range("B" & i + 3).Select
        If ActiveCell.Value = "" Then GoTo fin
        Range("D" & i + 3).Select
        ActiveCell.FormulaR1C1 = "=HYPERLINK(""#""&RC[-2],""ver la zona"")"
    Next i
fin:
    Columns("B:D").EntireColumn.AutoFit
'//////////////////////////////////////////////////
' reactiva los mensajes de Excel
'//////////////////////////////////////////////////
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

