الاخ شمس ، هذا هو الماكرو
جربه و أخبرني
Dim LetterMat(2, 37) As Variant
Sub Countaletter()
For j = 1 To 37
LetterMat(2, j) = 0
Next
LetterMat(1, 1) = "أ"
LetterMat(1, 2) = "ا"
LetterMat(1, 3) = "آ"
LetterMat(1, 4) = "إ"
LetterMat(1, 5) = "ب"
LetterMat(1, 6) = "ت"
LetterMat(1, 7) = "ث"
LetterMat(1, 8) = "ج"
LetterMat(1, 9) = "ح"
LetterMat(1, 10) = "خ"
LetterMat(1, 11) = "د"
LetterMat(1, 12) = "ذ"
LetterMat(1, 13) = "ر"
LetterMat(1, 14) = "ز"
LetterMat(1, 15) = "س"
LetterMat(1, 16) = "ش"
LetterMat(1, 17) = "ص"
LetterMat(1, 18) = "ض"
LetterMat(1, 19) = "ط"
LetterMat(1, 20) = "ظ"
LetterMat(1, 21) = "ع"
LetterMat(1, 22) = "غ"
LetterMat(1, 23) = "ف"
LetterMat(1, 24) = "ق"
LetterMat(1, 25) = "ك"
LetterMat(1, 26) = "ل"
LetterMat(1, 27) = "م"
LetterMat(1, 28) = "ن"
LetterMat(1, 29) = "ه"
LetterMat(1, 30) = "و"
LetterMat(1, 31) = "ي"
LetterMat(1, 32) = "ى"
LetterMat(1, 33) = "ئ"
LetterMat(1, 34) = "ؤ"
LetterMat(1, 35) = "ء"
LetterMat(1, 36) = "لا"
LetterMat(1, 37) = "لآ"
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 = 1 To 37
If .Text = LetterMat(1, j) Then LetterMat(2, j) = _
LetterMat(2, j) + 1
Next
End With
Next I
Dim m As String
For j = 1 To 37
m = m + (LetterMat(1, j)) + " : " + _
Str(LetterMat(2, j)) + Chr(13)
Next
MsgBox m
End Sub