DEJE QUE EXCEL HAGA EL TRABAJO SUCIO

Mostrar todas las fórmulas de uno o varios rangos

El siguiente código permitirá crear una matriz mostrando la dirección, el valor y la fórmula de uno o varios rangos seleccionados. Recuerde que puede seleccionar rangos no continuos manteniendo presionado la tecla Ctrl mientras los selecciona.

He comentado ampliamente el código para que sea fácil seguirlo y modificarlo según necesidades particulares.

También le puede resultar de interés la función definida por el usuario que se encuentra en este otro tema: Mostrar fórmula en una celda.
Sub MatrizValoresFormulas()
        
        
    Dim i As Long
    Dim lngTotalCeldas As Long
    Dim bytContinuar As Byte
    Dim rngCelda As Excel.Range
    Dim rngEntrada As Excel.Range
    Dim rngSalida As Excel.Range
    Dim arrResultado() As Variant
    
    '  Control de errores
    On Error GoTo err_MatrizValoresFormulas
    
    '  Asigna el rango de entrada. Se pueden seleccionar rangos
    '  no continuos manteniendo presionada la tecla Ctrl
    Set rngEntrada = Application.InputBox(prompt:="Seleccione las celdas cuya fórmula desea ver:", _
                                          Title:="Inspección", _
                                          Type:=8)
    
    '  Asigna el rango de salida a partir de una celda seleccionada
    Set rngSalida = Application.InputBox(prompt:="Seleccione una celda de salida:", _
                                         Title:="Inspección", _
                                         Type:=8)
        
    lngTotalCeldas = rngEntrada.Cells.Count
    
    ReDim arrResultado(0 To lngTotalCeldas, 1 To 3)
    
    '  Encabezados
    arrResultado(0, 1) = "Celda"
    arrResultado(0, 2) = "Valor"
    arrResultado(0, 3) = "Fórmula"
    
    '  Se construye la matriz con la dirección, el valor
    '  y la fórmula de cada celda del rango seleccionado
    For Each rngCelda In rngEntrada.Cells
        i = i + 1
        With rngCelda
        
            '  Dirección:
            '  RowAbsolute y ColumnAbsolute: Usar True para ref Absolutas ($A$1) y False para relativas (A1)
            '  ReferenceStyle: Usar xlA1 para ref tipo A1 y xlR1C1 para referencias tipo R1C1
            '  External: Usar True para mostrar la referencia completa (incluida la hoja y el libro) y False
            '            para mostrar solo la dirección de la celda
            arrResultado(i, 1) = .Address(RowAbsolute:=True, _
                                          ColumnAbsolute:=True, _
                                          ReferenceStyle:=xlA1, _
                                          External:=True)
                                          
            '  Valor
            arrResultado(i, 2) = .Value
            
            '  Fórmula de la celda
            If .HasFormula Then
                '  Si la celda tiene fórmula
                If .HasArray Then
                    '  Si es matricial encierra la fórmula entre {}
                    arrResultado(i, 3) = "{" & .FormulaLocal & "}"
                Else
                    '  De lo contrario, copia la fórmula
                    arrResultado(i, 3) = "'" & .FormulaLocal
                End If
            Else
                '  Si la celda no tiene fórmula devuelve #N/A
                arrResultado(i, 3) = VBA.CVErr(xlErrNA)
            End If
            
        End With
        
    Next rngCelda
    
    With rngSalida.Areas(1)
    
        bytContinuar = vbYes

        '  Verifica que no se vayan a borrar datos existentes en el rango de salida
        With .Resize(lngTotalCeldas + 1, 3)
            If Application.WorksheetFunction.CountA(.Cells) Then
                bytContinuar = VBA.MsgBox(prompt:="Esta operación borrará datos existentes en el rango de salida." _
                                                  & vbNewLine & vbNewLine & _
                                                  "¿Desea continuar?", _
                                          Buttons:=vbYesNo + vbQuestion, _
                                          Title:="Inspección")
            End If
            
            '  Se imprimen los resultado en el rango de salida
            If bytContinuar = vbYes Then
                .ClearFormats
                .Rows(1).Font.Bold = True
                .Value = arrResultado
            End If
            
        End With
          
    End With
    
    
Salir:
    Set rngSalida = Nothing
    Set rngEntrada = Nothing
    Erase arrResultado
    Exit Sub
    
err_MatrizValoresFormulas:
    Select Case Err.Number
        Case 424  '  Se canceló alguno de los inputbox
        'Case ...
        Case Else
            MsgBox "Error " & ": " & Err.Description, vbCritical, Err.Source
    End Select
    Resume Salir

End Sub

0 comentarios:

Publicar un comentario en la entrada