Showing percentage progress pictorially
Posted by Gerry Anderson on August 11, 2000 3:30 PM
I used to have a spreadsheet for tracking progress of certain activities (drawing production for instance). Whoever was responsible for the activity would enter in one column alongside that activity their percentage progress. This would then display in the next column cell a "progress bar" whcih looked similar to for instance the volume bar on a hifi. If progress was say 50% then half of the cell would be shaded, 75% three quarters of the cell shaded and so on.
Does anyone know the formula/ macro for setting this sort of feature up.
Posted by JAF on August 15, 0100 3:27 AM
The following macro puts a rectangle on the sheet to show the completion status of a range of cells (A9:A20) - it should be fairly easy to edit this to show the bar based on a % complete figure in a specific cell.
Hope this helps.
JAF
Sub show_percentage_complete()
Dim CompletedRows
CompletedRows = Application.WorksheetFunction.CountA(Range("$A$9:$A$20"))
Dim RowsToComplete
RowsToComplete = Rows.Range("$A$9:$A$20").Count
Dim percent_wide As Long
percent_wide = ((CompletedRows / RowsToComplete) * 100) * 1.92
'100% bar has width of 192 (in this case), therefore 1% = 1.92
On Error GoTo create_shape
ActiveSheet.Shapes("Box1").Delete
create_shape:
'RED if less than 100% - NB: 100% is a value IN THIS CASE of 192 (as above)
If percent_wide < 192 Then
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 96, 0, percent_wide, 12.75).Select
With Selection
.Name = "Box1"
.ShapeRange.Fill.Visible = msoTrue
.ShapeRange.Fill.Solid
.ShapeRange.Fill.ForeColor.SchemeColor = 10
.ShapeRange.Line.Weight = 1#
.ShapeRange.Line.DashStyle = msoLineSolid
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.ForeColor.SchemeColor = 64
.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End With
Else
'BLUE if 100%
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 96, 0, percent_wide, 12.75).Select
With Selection
.Name = "Box1"
.ShapeRange.Fill.Visible = msoTrue
.ShapeRange.Fill.Solid
.ShapeRange.Fill.ForeColor.SchemeColor = 12
.ShapeRange.Line.Weight = 1#
.ShapeRange.Line.DashStyle = msoLineSolid
.ShapeRange.Line.Style = msoLineSingle
.ShapeRange.Line.Visible = msoTrue
.ShapeRange.Line.ForeColor.SchemeColor = 64
.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End With
End If
ActiveCell.Select
End Sub
Posted by JAF on August 15, 0100 3:33 AM
Update
Oops - I forgot to mention, in order for that code to work you need to have the following code in the Sheet object:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Call show_percentage_complete
End Sub
Whenever the sheet changes, the macro show_percentage_complete will be run.
Posted by Celia on August 11, 0100 7:21 PM
Gerry
In the archives of this message board, have a look at judi's reply to Status Bars posted by Jim Bubb on February 02, 19100
Celia
