Function COMPROBAR(Rango As Range) As String
'--------------------------------------------------------
'Esta UDF, comprueba que los valores de las celdas de
'la última fila y última columna del rango, coincidan con
'el sumatorio de los valores de las celdas de sus respectivas
'filas y columnas del rango, en caso de diferencias, se añade
'un comentario con el valor calculado
'Ejemplo:
'
' Rango A3:D5, se comprueba que,
'
' A3+B3+C3=D3
' A4+B4+C4=D4
' A5+B6+C5=D5
' A3+A4=A5
' B3+B4=B5
' C3+C4=C5
' D3+D4=D5
'
'--------------------------------------------------------
Dim MAXROW As Double
Dim MAXCOLUMN As Double
Dim MINROW As Double
Dim MINCOLUMN As Double
Dim TOTAL As Double
Dim x As Double, y As Double
'--------------------------------------------------------
'Inicializamos variables
COMPROBAR = ""
MAXROW = 0: MAXCOLUM = 0
MINROW = 999999: MINCOLUMN = 999999
'--------------------------------------------------------
'Buscamos fila y columna de 1ª y última celda del rango
On Error Resume Next
For Each CELDA In Rango
CELDA.ClearComments
If CELDA.Row > MAXROW Then MAXROW = CELDA.Row
If CELDA.Column > MAXCOLUMN Then MAXCOLUMN = CELDA.Column
If CELDA.Row < MINROW Then MINROW = CELDA.Row
If CELDA.Column < MINCOLUMN Then MINCOLUMN = CELDA.Column
Next
'--------------------------------------------------------
'Si no hay rango, nos vamos
If MAXROW = MINROW And MAXCOLUMN = MINCOLUMN Then Exit Function
'--------------------------------------------------------
'Cuadramos filas
For x = MINROW To MAXROW
TOTAL = 0
For y = MINCOLUMN To MAXCOLUMN - 1
TOTAL = TOTAL + ActiveSheet.Cells(x, y)
Next y
If TOTAL <> ActiveSheet.Cells(x, MAXCOLUMN) Then
Beep
With ActiveSheet.Cells(x, MAXCOLUMN)
.AddComment
.Comment.Text Text:="Sumado: " & FormatNumber(TOTAL)
.Comment.Shape.Height = 20
.Comment.Shape.Width = Len(FormatNumber(TOTAL)) * 12 + 20
End With
End If
Next x
'--------------------------------------------------------
'Cuadramos columnas
For y = MINCOLUMN To MAXCOLUMN
TOTAL = 0
For x = MINROW To MAXROW - 1
TOTAL = TOTAL + ActiveSheet.Cells(x, y)
Next x
If TOTAL <> ActiveSheet.Cells(MAXROW, y) Then
Beep
With ActiveSheet.Cells(MAXROW, y)
.AddComment
.Comment.Text Text:="Sumado: " & FormatNumber(TOTAL)
.Comment.Shape.Height = 20 'Alto
.Comment.Shape.Width = Len(FormatNumber(TOTAL)) * 12 + 20
End With
End If
Next y
End Function
[/CODE]
Probarla a ver que os parece. Quizás ya exista, si es así, se ruega eliminar el post.
Hola:
Se explica por si solo.
Probarla a ver que os parece. Quizás ya exista, si es así, se ruega eliminar el post.
Saludos. Antoni.