استخراج الحروف من الجملة بشرط

[كريم الامين]

السلام عليكم ورحمة الله وبركاته

الاخوة الافاضل حياكم الله 

ارجو المساعدة في عمل ملف طلب مني وهو استخراج حروف معينة من الجملة وبتعبير ادق الحروف العربية عددها 28 حرف يتم تقسيمها الى اربعة اقسام 

اول سبعة حروف تسمى شرقية

ثاني سبعة حروف تسمى غربية

ثالث سبعة حروف تسمى شمالية

رابع سبعة حروف تسمى جنوبية

المطلوب عمل اربعة حقول حقل للحروف الشرقية واخر للغربية واخر للشمالية واخر للجنوبية

وحقل خاص بالجملة بحيث عند كتابة الجملة في الحقل الخاص بها تذهب الحروف الشرقية في حقل الحروف الشرقية وكذلك الغربية والشمالية والجنوبية

وشكرا لكم مسبقا ولكل الاخوة الافاضل

[سليم حاصبيا]

في اعتقادنا ان حروف اللغة العربية  28 حرفاً  

لكن الاكسل لا يعرفها هكذا 

لأن عنده  (أ , إ , ا ,آ ) كلها مختلفة

 ونفس الشيء بالنسبة لــ  (ت , ة , و , ؤ )  الخ......

لمعرفة كل الأخرف العربية غند الاكسل 

هذا الماكرو

Option Explicit

Sub test_me()
Dim i%, arr()
Dim k, Non_Arabic()
Dim m%
Non_Arabic = Array(215, 220, 224, 226, 231, 232, 233, 234, 235)
m = 1
For k = 1 To 46
 If IsError(Application.Match(k - 1 + 192, Non_Arabic, 0)) Then
  ReDim Preserve arr(1 To m)
  arr(m) = Chr(k - 1 + 192)
  m = m + 1
End If
Next
m = 2: k = 2
For i = 1 To UBound(arr)
Cells(m, k) = arr(i)
m = m + 1
If m = 9 Then m = 2: k = k + 1
Next
End Sub

الملف مرفق

 

Araabic_alpha.xlsm

[كريم الامين]

ا ستاذنا الرائع والطيب الاستاذ سليم المحترم كلامكم عين الصواب (أ , إ , ا ,آ ) اضافة الى( ى )هذا كله يعتبر حرف واحد من الاحرف ال 28 وهو حرف ا وكذلك نفس الشيئ (ت.ة )يعتبر حرف واحد وكذلك و ؤ حرف (واحد )

ارجو ان اكون قد وفقت بتوضيح الطلب جزاكم الله خيرا

 

الحروف العربية.xlsx

[سليم حاصبيا]

ربما يكون المطلوب

Option Explicit
Dim E, W, N, S 'FROM CELL Z1 TO AC11
Dim t%, L%, letr
Dim Co1(), a%, B_E As Boolean
Dim Co2(), b%, B_W As Boolean
Dim Co3(), c%, B_N As Boolean
Dim Co4(), d%, B_S As Boolean
'+++++++++++++++++++++
 Sub quelque_chose()
If ActiveSheet.Name <> "Salim" Then Exit Sub

E = Array(193, 194, 195, 197, 199, 200, 201, _
        202, 203, 204, 205, 206, 236)
W = Array(207, 208, 209, 210, 211, 212, 213)
N = Array(214, 216, 217, 218, 219, 221, 222)
S = Array(192, 196, 198, 223, 225, 227, 228, _
    229, 230, 237)
 
End Sub
'+++++++++++++++++++++
Sub My_test()
quelque_chose
Range("E2:H100").ClearContents
L = Len(Cells(2, "C"))
 
a = 1: b = 1: c = 1: d = 1
 For t = 1 To L
  letr = Mid(Cells(2, "C"), t, 1)
   If letr = " " Then GoTo next_t
   If Asc(letr) >= 65 And _
    Asc(letr) <= 122 Then GoTo next_t
   B_E = Not IsError(Application.Match(Asc(letr), E, 0))
   B_W = Not IsError(Application.Match(Asc(letr), W, 0))
   B_N = Not IsError(Application.Match(Asc(letr), N, 0))
   B_S = Not IsError(Application.Match(Asc(letr), S, 0))
Select Case True
    Case B_E
        ReDim Preserve Co1(1 To a)
        Co1(a) = letr
        a = a + 1
    Case B_W
        ReDim Preserve Co2(1 To b)
        Co2(b) = letr
        b = b + 1
    Case B_N
        ReDim Preserve Co3(1 To c)
        Co3(c) = letr
        c = c + 1
    Case B_S
        ReDim Preserve Co4(1 To d)
        Co4(d) = letr
        d = d + 1
    Case Else
   GoTo next_t

End Select
next_t:
 Next
   If a > 1 Then
      Range("E2").Resize(UBound(Co1)) = _
      Application.Transpose(Co1)
   End If
   If b > 1 Then
      Range("F2").Resize(UBound(Co2)) = _
      Application.Transpose(Co2)
   End If
   If c > 1 Then
      Range("G2").Resize(UBound(Co3)) = _
      Application.Transpose(Co3)
   End If
   If d > 1 Then
      Range("H2").Resize(UBound(Co4)) = _
      Application.Transpose(Co4)
   End If
End Sub

الملف للمعاينة مرفق

Arabic_Alphabet.xlsm

[كريم الامين]

تمام استاذ احسنتم وشكرا لجهودكم هذا هو المطلوب وفقكم الله لكل خير

الحقيقة الاستاذ سليم يستحق مليون اعجاب ليس فقط لانه استجاب لطلبي بارك الله فيه ولكن لانه سباق في تقديم يد العون لكل الاخوة

ولكن للاسف لم انتبه لوجود زر الاعجاب