Count number of occurrences for a number of ranges from a find loop

Hello, I need to display the number of occurrences for each range within an array and put this value offset to the range cell. I have attached an example workbook of what I need to happen. The Macro (See below) works fine, just need to figure out how to count how many of each it finds. Just cant get my head around it? My Vba is very basic, hope someone can help?

Option Explicit
Sub Mark_Cells_In_Column()
 Dim FirstAddress As String, I As Long
 Dim MyArr As Variant, Rng As Range, Sh As Worksheet

 Sheets("Sheet1").Select
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
 End With
 MyArr = Array(Range("A4").Value, Range("A5").Value, Range("A6").Value, Range("A7").Value, Range("A8").Value, Range("A9").Value, Range("A10").Value, Range("A11").Value, Range("A12").Value, Range("A13").Value)
 For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "Sheet1" Then
        With Sh.Range("A:A")
 '           .Offset(0, 1).ClearContents
            For I = LBound(MyArr) To UBound(MyArr)
            If MyArr(I) <> "" Then
                Set Rng = .Find(What:=MyArr(I), After:=.Cells(.Cells.Count), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    FirstAddress = Rng.Address
                    Do
                        Rng.Offset(0, 1).Value = Range("D2").Value  'D1<=|'
                        Rng.Offset(0, 2).Value = Range("E2").Value  'E1<=|'
                        Set Rng = .FindNext(Rng)
                    Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                End If
                End If
            Next I
        End With
    End If
 Next Sh
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
 End With
End Sub

Thanks