Cómo listar los formatos personalizadas

[pegones1]

Es muy fácil obtener el listado de los formatos de celdas personalizadas con el botón derecho del ratón y click en "Formato de celdas..." como se ve en la imagen:

Lo que no es tan fácil es que ese listado se obtenga en Excel. Lo único que he encontrado en la Web es:

[DBOX]http://www.j-walk.com/ss/excel/eee/eee007.txt[/DBOX]

Basándome en la idea expuesta en el texto del enlace, por Leo Heuser, he conseguido la siguiente macro que proporciona una solución para la falta flagrante de accesibilidad en VBA para manipular los formatos de número personalizados. Para ello, se hackea el cuadro de diálogo "Formato de celdas" con la función SendKeys. Espero que os guste.

Option Explicit



Sub ListaFormatosPersonalizados()

    Dim GuardaFormato As Variant

    Dim Contador As Long

    Dim sCelda As String


    sCelda = "B1"        'Buffer de la celda auxiliar

    If MsgBox("Obtiene la lista de los formatos personalizados", vbOKCancel) _

        = vbCancel Then Exit Sub

    With Worksheets.Add

        .Move after:=Worksheets(Worksheets.Count)

        .Name = "FormatosPersonalizados"

        .Activate

    End With

    With Range("A1")

        .Value = "Lista de los formatos personalizados"

        .Font.Bold = True

        Range(sCelda).Select

        .Offset(1, 0).Value = Range(sCelda).NumberFormatLocal

        Contador = 2

        Do

            GuardaFormato = Range(sCelda).NumberFormatLocal

            SendKeys "{tab 3}{down}{enter}"

            Application.Dialogs(xlDialogFormatNumber).Show GuardaFormato

            .Offset(Contador, 0).Value = Range(sCelda).NumberFormatLocal

            Contador = Contador + 1

        Loop Until Range(sCelda).NumberFormatLocal = GuardaFormato

        .Offset(Contador - 1, 0).Value = ""

    End With

    With Range("A1:A" & Contador - 1)

        .EntireColumn.AutoFit

        .HorizontalAlignment = xlLeft

        .NumberFormat = "@"

    End With

    MsgBox "Nº de formatos personalizados = " & Contador - 2

End Sub


[/CODE]

Con la que se obtiene la lista deseada en la hoja "FormatosPersonalizados":

[TABLE=width: 340]

[TR]

[TD][b]Lista de los formatos personalizados[/b][/TD]

[/TR]

[TR]

[TD]Estándar[/TD]

[/TR]

[TR]

[TD]0[/TD]

[/TR]

[TR]

[TD]0,00[/TD]

[/TR]

[TR]

[TD]#.##0[/TD]

[/TR]

[TR]

[TD]#.##0,00[/TD]

[/TR]

[/TABLE]

...

[Antoni]

Curioso, si señor.

Buscando he encontrado este enlace que también puede ser interesante.

Delete Custom Formats - Microsoft Community

Además es sospechosamente parecido al link que tu indicas.

[pegones1]

Macro, ya ves que te hago la competencia con aportes con macros.

El enlace que comentas es del año 2011 y el que contestó se debió leer el original que es del 15 de junio de 1999.

Lo acabo de buscar y es el mismo que enlacé en el post #1 en el que me basé para obtener la lista:

[DBOX]The Spreadsheet Page - Excel Expert E-Letter: Issue No. 07 (June 15, 1999)[/DBOX]

COMMENTS

Welcome to the 7th issue of the Excel Experts E-letter (or EEE), by David Hager. EEE is a semi-monthly publication. Feel free to distribute copies of EEE to your friends and colleagues.

POWER PROGRAMMING TECHNIQUE

By Leo Heuser

This procedure provides a workaround for the glaring lack of accessibilityin VBA for manipulating custom number formats. To do this, it hacks into the Number Format dialog box with SendKeys. It loops through each item, including those custom number formats that have been orphaned from the worksheet. The dialog box flickers upon each opening, but it works! If anyone comes up with a way to eliminate the flicker, let me know.

Hace años que se publican y comparten tips para Excel y éste permite borrar formatos personalizados que no se usan en la hoja de cálculo.

Option Explicit


Sub DeleteUnusedCustomNumberFormats()

'

' http://www.j-walk.com/ss/excel/eee/eee007.txt

' By Leo Heuser

'

    Dim Buffer As Object

    Dim Sh As Object

    Dim SaveFormat As Variant

    Dim fFormat As Variant

    Dim nFormat() As Variant

    Dim xFormat As Long

    Dim Counter As Long

    Dim Counter1 As Long

    Dim Counter2 As Long

    Dim StartRow As Long

    Dim EndRow As Long

    Dim Dummy As Variant

    Dim pPresent As Boolean

    Dim NumberOfFormats As Long

    Dim Answer

    Dim c As Object

    Dim DataStart As Long

    Dim DataEnd As Long

    Dim AnswerText As String



    NumberOfFormats = 1000

    ReDim nFormat(0 To NumberOfFormats)

    AnswerText = "Do you want to delete unused custom formats from the workbook?"

    AnswerText = AnswerText & Chr(10) & "To get a list of used and unused formats only, choose No."

    Answer = MsgBox(AnswerText, 259)

    If Answer = vbCancel Then GoTo Finito



    On Error GoTo Finito

    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

    Worksheets(Worksheets.Count).Name = "CustomFormats"

    Worksheets("CustomFormats").Activate

    Set Buffer = Range("A2")

    Buffer.Select

    nFormat(0) = Buffer.NumberFormatLocal

    Counter = 1

    Do

        SaveFormat = Buffer.NumberFormatLocal

        Dummy = Buffer.NumberFormatLocal

        DoEvents

        SendKeys "{tab 3}{down}{enter}"

        Application.Dialogs(xlDialogFormatNumber).Show Dummy

        nFormat(Counter) = Buffer.NumberFormatLocal

        Counter = Counter + 1

    Loop Until nFormat(Counter - 1) = SaveFormat



    ReDim Preserve nFormat(0 To Counter - 2)



    Range("A1").Value = "Custom formats"

    Range("B1").Value = "Formats used in workbook"

    Range("C1").Value = "Formats not used"

    Range("A1:C1").Font.Bold = True



    StartRow = 3

    EndRow = 16384



    For Counter = 0 To UBound(nFormat)

        Cells(StartRow, 1).Offset(Counter, 0).NumberFormatLocal = nFormat(Counter)

        Cells(StartRow, 1).Offset(Counter, 0).Value = nFormat(Counter)

    Next Counter



    Counter = 0

    For Each Sh In ActiveWorkbook.Worksheets

        If Sh.Name = "CustomFormats" Then Exit For

        For Each c In Sh.UsedRange.Cells

            fFormat = c.NumberFormatLocal

            If Application.WorksheetFunction.CountIf(Range(Cells(StartRow, 2), Cells(EndRow, 2)), fFormat) = 0 Then

                Cells(StartRow, 2).Offset(Counter, 0).NumberFormatLocal = fFormat

                Cells(StartRow, 2).Offset(Counter, 0).Value = fFormat

                Counter = Counter + 1

            End If

        Next c

    Next Sh



    xFormat = Range(Cells(StartRow, 2), Cells(EndRow, 2)).Find("").Row - 2

    Counter2 = 0

    For Counter = 0 To UBound(nFormat)

        pPresent = False

        For Counter1 = 1 To xFormat

            If nFormat(Counter) = Cells(StartRow, 2).Offset(Counter1, 0).NumberFormatLocal Then

                pPresent = True

            End If

        Next Counter1

        If pPresent = False Then

            Cells(StartRow, 3).Offset(Counter2, 0).NumberFormatLocal = nFormat(Counter)

            Cells(StartRow, 3).Offset(Counter2, 0).Value = nFormat(Counter)

            Counter2 = Counter2 + 1

        End If

    Next Counter

    With ActiveSheet.Columns("A:C")

        .AutoFit

        .HorizontalAlignment = xlLeft

    End With

    If Answer = vbYes Then

        DataStart = Range(Cells(1, 3), Cells(EndRow, 3)).Find("").Row + 1

        DataEnd = Cells(DataStart, 3).Resize(EndRow, 1).Find("").Row - 1

        On Error Resume Next

        For Each c In Range(Cells(DataStart, 3), Cells(DataEnd, 3)).Cells

            ActiveWorkbook.DeleteNumberFormat (c.NumberFormat)

        Next c

    End If

Finito:

    Set c = Nothing

    Set Sh = Nothing

    Set Buffer = Nothing

End Sub

[/CODE]

Si comparas este código original con mi aporte verás que lo he simplificado al máximo para centrarme en obtener la lista de formatos personalizados.

[Antoni]

Ya he visto que lo has "españolizado", el Sr.Wert te dará una beca,.....jajaja

Sigue haciéndome la competencia que al menos nos reiremos.

Un abrazo.

[pegones1]

Lo de pedir becas, no lo veo, que últimamente la dan a los sabiendos y superdotados como el Sr. Wert.

Lo que si le pediría a ese Sr. es que, en cuanto deje el ministerio, nos ayude a traducir las macros, que con seis idiomas es el ministro más políglota del Gobierno y, además, presume de aprenderlos en pocas sesiones, no como a nosotros que nos cuesta toda la vida.

Es más fácil para mí desinstalar su nombre de mi ordenador que estudiar idiomas.

[pegones1]

Macro, si te gustó el vídeo, mira este teclado Q....Y que ya conoces y de paso me cargo la tecla del euro €.

[DBOX]https://www.ayudaexcel.com/foro/ideas-aportes-64/teclado-virtual-17803/[/DBOX]

Teclado Q....Y.xls