Sub Listado_Hojas()
'19-abr-11
Dim dato As Long
Dim rangoA1 As Range
Dim NuevoNombre, Resp
'Se validan archivos abiertos.
'
On Error GoTo Errores
Application.StatusBar = "Creando índice ..."
Application.ScreenUpdating = False
ActiveWorkbook.Sheets.Add Before:=Sheets(1)
Set rangoA1 = Sheets(1).Range("a1")
Sheets(1).Range("a1").Value = "ÍNDICE"
dato = ActiveWorkbook.Sheets.Count
Application.Calculation = xlCalculationManual
For i = 1 To dato
With Sheets(1)
.Hyperlinks.Add Anchor:=rangoA1.Offset(i, 0), Address:="", _
SubAddress:="'" & Sheets(i).Name & "'" & "!A1", _
TextToDisplay:="+'" & Sheets(i).Name & "'" & "!C4"
End With
Next i
ActiveSheet.Range("A2").EntireRow.Delete
Application.ScreenUpdating = True
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
Cells.Select
ActiveWindow.DisplayGridlines = False
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("B1").Select
Columns("B:B").ColumnWidth = 36.29
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Resp = MsgBox("Desea asignarle un nombre la hoja de índice creada?", vbYesNoCancel + vbQuestion, AddIn)
If Resp = vbYes Then
Application.Dialogs(xlDialogWorkbookName).Show
Else
Exit Sub
End If
Exit Sub
Errores:
Application.Calculation = xlCalculationAutomatic
MsgBox "Ha ocurrido un error: " & vbNewLine & vbNewLine & Err.Description, vbExclamation, AddIn
End Sub
%5D_2013-05-22_13-58-49.png)