Function BoxChartUp(Diapazon As Range)
Dim rng As Range
Dim shp As Shape
Ma = Diapazon.Rows( 1 )
Mi = Diapazon.Rows( 1 )
For i =  1  To Diapazon.Rows.Count
    If Ma < Diapazon.Rows(i) Then Ma = Diapazon.Rows(i)
    If Mi > Diapazon.Rows(i) Then Mi = Diapazon.Rows(i)
Next i

For i =  1  To Diapazon.Rows.Count
Set rng = Diapazon(i)
BoxShapeDelete rng
Set shp = rng.Worksheet.Shapes.AddShape(msoShapeRectangle, rng.Left, rng.Top, CSng(rng.Width * (Diapazon(i).Value - Mi) / (Ma - Mi)), rng.Height)

With shp
    .Fill.ForeColor.SchemeColor =  12 
    .Fill.Transparency =  0 #
    .Fill.OneColorGradient msoGradientVertical,  1 ,  0 . 81 
    .Fill.Transparency =  1 #
    .Line.Weight =  0 . 75 
    .Line.DashStyle = msoLineSolid
    .Line.Style = msoLineSingle
    .Line.Transparency =  0 #
    .Line.Visible = msoTrue
    .Line.ForeColor.SchemeColor =  64 
    .Line.BackColor.RGB = RGB( 255 ,  255 ,  255 )
    .Fill.Visible = msoTrue
    .Fill.ForeColor.SchemeColor =  12 
    .Fill.OneColorGradient msoGradientVertical,  1 ,  0 . 81 
    .Line.ForeColor.SchemeColor =  44 
    .Line.Visible = msoTrue
    .Line.Weight =  0 . 25 
    .Line.Visible = msoTrue
    .Line.Style = msoLineSingle
End With
Next i
End Function

Sub BoxShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean
 
    For Each shp In rngSelect.Worksheet.Shapes
        blnDelete = False
        Set rng = rngSelect
        If Not rng Is Nothing Then
            If rng.Left = shp.Left And rng.Top = shp.Top Then blnDelete = True
        End If
        If blnDelete Then shp.Delete
    Next
End Sub