Creando una nueva hoja
Sub ListarNombres1() Dim wks As Worksheet Set wks = Worksheets.Add wks.Range("A1").ListNames wks.Columns("A:B").Columns.AutoFit End SubMás simplificadamente aún:
Sub ListarNombres2() Sheets.Add Range("A1").ListNames Columns("A:B").AutoFit End Sub
Cuadro de diálogo
Otra opción que he escrito, consiste en elegir mediante un cuadro de diálogo el rango donde queremos que liste los nombres.
Sub ListarNombres3() Dim myRange As Range Set myRange = Application.InputBox(Prompt:="Selecciona celda vacía", _ Title:="Listado de nombres", Type:=8) myRange.ListNames End SubEl inconveniente de la macro anterior es que al copiar el listado de nombres, si no sabemos el número de nombres del libro, puede sobreescribir celdas. Para evitarlo he creado el siguiente código. Crea una hoja temporal con el listado de nombres y, a partir de la celda seleccionada, calcula si el rango necesario para copiar los nombres está vacío o no. Si no lo está, no copiará el listado de nombres.
Sub ListarNombres4() Dim sInicial As String sInicial = ActiveSheet.Name Dim sName As String Worksheets.Add.Name = "temp" Sheets("temp").Range("A1").ListNames Dim i As Integer i = [COUNTA(temp!A:A)] Sheets(sInicial).Select On Error GoTo Final Dim myRange As Range Set myRange = Application.InputBox(Prompt:="Elige celda con" & _ " región vacía alrededor de 2 columnas por" & i & " filas", _ Title:="Listado de nombres", Type:=8) If RangeIsBlank(myRange.Resize(i, 2)) = False Then MsgBox "Rango no vacío. No se puede copiar aquí.", vbCritical GoTo Final Else End If myRange.ListNames myRange.Resize(i, 2).Columns.AutoFit Final: Application.DisplayAlerts = False Worksheets("temp").Delete Application.DisplayAlerts = True End SubPara emplear la macro anterior es preciso incluir en un módulo del libro la siguiente función de Dick Kusleika.
Function RangeIsBlank(rRng As Range) As Boolean If IsNull(rRng.FormulaArray) Then RangeIsBlank = False Else RangeIsBlank = Len(rRng.FormulaArray) = 0 End If End Function
No hay comentarios:
Publicar un comentario