martes, 27 de marzo de 2018

VBA: Crear un índice de hojas con autoformas

Veremos en el post de hoy como generar en Excel un índice de todas las hojas que existan en nuestro libro de trabajo, pero en este caso asociándolo a unas Autoformas...
Tal como se ve en la imagen siguiente:

VBA: Crear un índice de hojas con autoformas



Esta personalización no permitirá crear rápidamente un índice de hojas empleando nuestras autoformas favoritas, con las características de formato de forma que deseemos...
Importante!, el índice se genera en una hoja que he llamado 'Menu'.


En un módulo estándar del libro incluimos el siguiente procedimiento:

Sub CreaIndice_con_AutoForma()
Dim wks As Worksheet

alt = 0
For Each sh In Sheets
    If sh.Name <> "Menu" Then
        Set wks = Worksheets("Menu")
        Dim miForma As Shape
        'definimos la forma de Rectángulo redondeado
        ' .AddShape ( Tipo , izquierda , arriba , ancho , alto )
        Set miForma = wks.Shapes.AddShape(msoShapeRoundedRectangle, 5, 10 + alt, 75, 50)
        alt = alt + 60
        'añadimos como texto el nombre de la hoja destino/ en negrita
        With miForma.TextFrame.Characters
            .Text = "Ir a " & sh.Name
            .Font.Bold = True
        End With
        'alineamos texto centrado vertical/horizontal
         With miForma
            .TextFrame2.VerticalAnchor = msoAnchorMiddle
            .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        End With
        'carácterísticas 3D de la forma con Bisel circular
        miForma.ThreeD.BevelTopType = msoBevelCircle
        'y del color de fondo
        miForma.Fill.ForeColor.RGB = RGB(197, 90, 17)
        'y también efecto de luminosidad
        With miForma.Glow
            .Color.RGB = RGB(197, 90, 17)
            .Transparency = 0.6
            .Radius = 8
        End With
        
        ' y finalmente añadimos la funcionalidad de hipervínculo a la Autoforma
        wks.Hyperlinks.Add Anchor:=miForma, _
                address:="", _
                SubAddress:=sh.Name & "!" & Cells(1, 1).address
    End If
Next sh

End Sub



El resultado se visualiza rápidamente.

Se observa como el orden de las hojas es el mismo en el que aparecen dispuestas en el libro...

7 comentarios:

  1. Respuestas
    1. Hola qué tal estás?
      un placer saludarte igualmente
      ASegúrate que la fila 37:
      address:="", _
      te aparece el guión bajo después de un espacio en blanco
      Saludos

      Eliminar
  2. Hola Isamel por favor me podrías ayudar con la siguiente macro

    Necesito sumar un rango de una tabla de datos, según unos IDs y dos criterios, hasta el momento he conseguido que me sume el valor según el ID, pero necesito que me sume teniendo en cuenta el ID y los criterios 1 y 2
    con esta macro sumo los ID pero necesito el requerimiento anterior
    Sub sumarSS()
    Set h11 = Sheets("EJEMPLO1")
    Set h14 = Sheets("RESUMEN")
    h14.Cells.ClearContents
    h11.[B9:AB9].Copy h14.[B9]
    h14.[A9] = "REG"
    '
    r = 1
    For i = 10 To h11.Range("E" & Rows.Count).End(xlUp).Row
    Set s = h14.Columns("E").Find(h11.Cells(i, "E").Value, lookat:=xlWhole)
    If Not s Is Nothing Then
    h14.Cells(s.Row, "Q").Value = h14.Cells(s.Row, "Q").Value + h11.Cells(i, "Q").Value
    Else
    u1 = h14.Range("A" & Rows.Count).End(xlUp).Row + 1
    h14.Cells(u1, "A").Value = r
    h14.Cells(u1, "E").Value = h11.Cells(i, "E").Value
    h14.Cells(u1, "F").Value = h11.Cells(i, "F").Value
    h14.Cells(u1, "Q").Value = h11.Cells(i, "Q").Value
    r = r + 1
    End If
    Next
    For h = 10 To h11.Range("G" & Rows.Count).End(xlUp).Row
    Set p = h14.Columns("G").Find(h11.Cells(h, "G").Value, lookat:=xlWhole)
    If Not p Is Nothing Then
    h14.Cells(p.Row, "R").Value = h14.Cells(p.Row, "R").Value + h11.Cells(h, "R").Value
    Else
    u2 = h14.Range("A" & Rows.Count).End(xlUp).Row + 1
    h14.Cells(u2, "A").Value = r
    h14.Cells(u2, "G").Value = h11.Cells(h, "G").Value
    h14.Cells(u2, "H").Value = h11.Cells(h, "H").Value
    h14.Cells(u2, "R").Value = h11.Cells(h, "R").Value
    r = r + 1

    End If
    Next

    MsgBox "Fin"
    End Sub

    ResponderEliminar
  3. Con este otro código también logro sumar y resumir pero solo depediendo del ID también me falta que tenga el cuenta los dos criterios

    Sub ResumenID()
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("E2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("E2:E65535").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=SUMIFS(C[-2],C[-5],RC[-1])"
    Range("F2").Select
    Selection.AutoFill Destination:=Range("F2:F" & Application.WorksheetFunction.CountA(Range("e2:e65536")) + 1)
    End Sub


    ResponderEliminar
  4. Con el último código lo datos están de esta manera:

    A1 B1 C1 D1 E1 F1
    ID CC GRUPO TOTAL ID COSOLIDA TOTAL CONSOLIDADO
    473 243 72 71000
    473 243 72 66000
    264 243 72 60000
    264 243 72 72000
    105 243 51 66000
    264 231 72 66000
    184 086 51 11000
    473 233 51 17000

    ResponderEliminar
    Respuestas
    1. Hola Javier,
      por que no empleas sencillamente la función SUMAR.SI.CONJUNTO (sumifs)...
      =SUMAR.SI.CONJUNTO(rango_a_sumar;rng_criterio1;criterio1;rng_criterio2;criterio2)
      es decir, trabaja sobre rangos y no sobre celdas...
      Saludos

      Eliminar