Sub Paint()
'
' Paint Macro
'
'
    Dim r As Range
    Dim Minimo As Single, Maximo As Single
    Dim i As Integer, j As Integer
    Dim esc As Single, bit As Single, low As Single, high As Single
    
    Set r = Application.InputBox(prompt:="Enter range to paint", Type:=8)
    
    Minimo = 1000000#
    Maximo = -1000000#
    
    For i = 1 To r.Rows.Count
        For j = 1 To r.Columns.Count
            If r(i, j) < Minimo Then Minimo = r(i, j)
            If r(i, j) > Maximo Then Maximo = r(i, j)
        Next j
    Next i
    
    esc = 768 / (Maximo - Minimo)
    For i = 1 To r.Rows.Count
        For j = 1 To r.Columns.Count
            With r(i, j).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                bit = 768 - (esc * (r(i, j) - Minimo))
                If bit < 128 Then
                    low = 0
                    high = 0
                Else
                    If bit > 512 Then
                        low = bit - 512
                        high = 255
                        bit = 127
                    Else
                        low = 0
                        high = bit - 128
                        bit = 127
                    End If
                End If
                    
                
                
                .Color = RGB(low, high, 128 + bit)
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        Next j
    Next i
    r(1, 1).Select
    
End Sub