عمل إحصائية لعدد جميع أنواع الحروف

[محمد طاهر عرفه]

هذا كود لعمل احصائية لانواع الحروف المختلفة

Dim LetterMat(2, 256) As Variant


Sub Countaletter()


For i = 32 To 255

 LetterMat(2, i) = 0

Next


For i = 32 To 255

 LetterMat(1, i) = Chr(i)

Next


Application.ScreenUpdating = True

Mycounter = 0

Selection.WholeStory

Mcount = Selection.Characters.Count

     ' MsgBox mcount

   For i = 1 To Mcount


    With Selection.Characters(i)

          Application.StatusBar = "Searching  ...." & _

             i & "/" & Mcount & "       Please Wait......."

        For j = 32 To 255

          If .Text = LetterMat(1, j) Then LetterMat(2, j) = _

          LetterMat(2, j) + 1

        Next

    End With

   Next i

   Dim m As String

   

   For j = 32 To 64

   m = m + (LetterMat(1, j)) + ":" + _

   Str(LetterMat(2, j)) + "          "  ' + Chr(13)

   If j Mod 3 = 0 Then m = m + Chr(13)

   Next

   MsgBox m

m = ""

   For j = 65 To 90

   m = m + (LetterMat(1, j)) + ":" + _

   Str(LetterMat(2, j)) + "          "  ' + Chr(13)

   If j Mod 3 = 0 Then m = m + Chr(13)

   Next

   MsgBox m

m = ""

For j = 91 To 122

   m = m + (LetterMat(1, j)) + ":" + _

   Str(LetterMat(2, j)) + "          "  ' + Chr(13)

   If j Mod 3 = 0 Then m = m + Chr(13)

   Next

   MsgBox m

m = ""

   For j = 123 To 192

   m = m + (LetterMat(1, j)) + ":" + _

   Str(LetterMat(2, j)) + "          "  ' + Chr(13)

   If j Mod 3 = 0 Then m = m + Chr(13)

   Next

   MsgBox m

m = ""

   For j = 192 To 255

   m = m + (LetterMat(1, j)) + ":" + _

   Str(LetterMat(2, j)) + "          "  ' + Chr(13)

   If j Mod 3 = 0 Then m = m + Chr(13)

   Next

   MsgBox m

End Sub

CountallLetternew.zip