Adding Shapes on every cell based on cell value.

[SirAz]

I am pretty new in VBA in excel. How can I add shape in every cell that contain "Late"?
Please help. Thanks.


Sub InsertShapeLateDays()
Dim ws As Worksheet
Dim LastRow As Long
Dim LateCount As Integer
Dim LastColumn As Long
Dim i As Long
Dim lateCell As Range
Dim lateShape As Shape

Set ws = ThisWorkbook.Worksheets("Attendance")

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column

LateCount = 0

For i = 2 To LastRow ' Assuming row 1 is the header
If ws.Cells(i, LastColumn).Value = "Late" Then
LateCount = LateCount + 1

Set lateCell = ws.Cells(i, LastColumn)

Set lateShape = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, _
lateCell.Left, lateCell.Top, lateCell.Width, lateCell.Height)
lateShape.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Red color
End If
Next i

MsgBox "The person was late " & LateCount & " times."
End Sub

This code only insert shape in the last column that contains "Late"

Here is my screenshot.
Please help.

 

[duggie33]

In the following line, you are only checking values in the LastColumn...

If ws.Cells(i, LastColumn).Value = "Late" Then

I left your code mostly as it was, but made changes to create a range from your data and then check each cell in the range to see if it's value is "Late".

Sub InsertShapeLateDays()

    Dim ws As Worksheet
    Dim LastRow As Long
    Dim LateCount As Integer
    Dim LastColumn As Long
    Dim rngToCheck As Range
    Dim rng As Range
    Dim i As Long
    Dim lateShape As Shape

    Set ws = ThisWorkbook.Worksheets("Sheet2")

    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set rngToCheck = ws.Range("A2").Resize(LastRow - 1, LastColumn)
    
    LateCount = 0

    For Each rng In rngToCheck 'Assuming row 1 is the header
        If rng.Value = "Late" Then
            LateCount = LateCount + 1
            Set lateShape = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, _
            rng.Left, rng.Top, rng.Width, rng.Height)
            lateShape.Fill.ForeColor.RGB = RGB(0, 0, 0) 'Black color
        End If
    Next rng

    MsgBox "The person was late " & LateCount & " times."

End Sub

I hope that helps,

Doug

 

[SirAz]

In the following line, you are only checking values in the LastColumn...

If ws.Cells(i, LastColumn).Value = "Late" Then

I left your code mostly as it was, but made changes to create a range from your data and then check each cell in the range to see if it's value is "Late".

Sub InsertShapeLateDays()

    Dim ws As Worksheet
    Dim LastRow As Long
    Dim LateCount As Integer
    Dim LastColumn As Long
    Dim rngToCheck As Range
    Dim rng As Range
    Dim i As Long
    Dim lateShape As Shape

    Set ws = ThisWorkbook.Worksheets("Sheet2")

    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
   
    Set rngToCheck = ws.Range("A2").Resize(LastRow - 1, LastColumn)
   
    LateCount = 0

    For Each rng In rngToCheck 'Assuming row 1 is the header
        If rng.Value = "Late" Then
            LateCount = LateCount + 1
            Set lateShape = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, _
            rng.Left, rng.Top, rng.Width, rng.Height)
            lateShape.Fill.ForeColor.RGB = RGB(0, 0, 0) 'Black color
        End If
    Next rng

    MsgBox "The person was late " & LateCount & " times."

End Sub

I hope that helps,

Doug

Thanks. it worked well. I edited some of the lines and apply it in another attendance checker file. thanks

 

[duggie33]

Glad to help.

Doug