Sub Label4EmptyRows()
Dim z As Integer
Dim counter As Integer
Dim i As Integer
Dim lastR As Integer
Dim where As String
lastR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'A as example, column with word COMPLETED in your case
For z = 1 To lastR
counter = 0
If Cells(z, "A").Value = "" Then 'A as above
where = Cells(z, "A").Address 'A as above
For i = Cells(z, "A").Row To lastR 'A as above
If Cells(i, "A").Value = "" Then 'A as above
counter = counter + 1
Else
z = z + counter
Exit For
End If
Next i
Call putInfo(where, counter)
End If
Next z
End Sub
Sub putInfo(where As String, info As Integer)
Dim s As Shape
Dim ws As Worksheet
Set ws = ActiveSheet
Set s = ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 10, 10)
With s
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.TextRange.Font.Size = 20
.TextFrame.Characters.Text = "" & info
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.Top = Range(where).Top + (Range(where).Height / 2)
.Left = Range(where).Left + (Range(where).Width / 2)
.Width = Range(where).Width
.Height = Range(where).Height * (info - 1)
End With
End Sub