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