Dim s As Shape, sr As ShapeRange
  Set sr = ActiveSelectionRange
   
  Dim d As Variant, str As String
  Set d = CreateObject("Scripting.dictionary")
  
   For Each s In sr
    If s.Type = cdrTextShape Then
      str = s.Text.Story.Text
      If d.Exists(str) = True Then
        d.Item(str) = d.Item(str) + 1
      Else
        d.Add str, 1
      End If
    End If
  Next s
  

  str = "Text" & vbTab & vbTab & "Quantity" & vbNewLine
  a = d.keys: b = d.items
  For i = 0 To d.Count - 1
    str = str & a(i) & vbTab & b(i) & "Strip" & vbNewLine
  Next
  str = str & "Total:" & vbTab & vbTab & d.Count & "Strip" & vbNewLine

  Debug.Print str
  ActiveDocument.Unit = cdrMillimeter
  
  Dim s1 As Shape
  x = sr.FirstShape.LeftX - 100
  y = sr.FirstShape.TopY
  Set s1 = ActiveLayer.CreateParagraphText(x, y, x + 90, y - 150, str, Font:="Khmer song")
End Sub

 @ * :