كريم الامين قام بنشر أغسطس 26, 2020 مشاركة قام بنشر أغسطس 26, 2020 السلام عليكم ورحمة الله وبركاته الاخوة الافاضل حياكم الله ارجو المساعدة في عمل ملف طلب مني وهو استخراج حروف معينة من الجملة وبتعبير ادق الحروف العربية عددها 28 حرف يتم تقسيمها الى اربعة اقسام اول سبعة حروف تسمى شرقية ثاني سبعة حروف تسمى غربية ثالث سبعة حروف تسمى شمالية رابع سبعة حروف تسمى جنوبية المطلوب عمل اربعة حقول حقل للحروف الشرقية واخر للغربية واخر للشمالية واخر للجنوبية وحقل خاص بالجملة بحيث عند كتابة الجملة في الحقل الخاص بها تذهب الحروف الشرقية في حقل الحروف الشرقية وكذلك الغربية والشمالية والجنوبية وشكرا لكم مسبقا ولكل الاخوة الافاضل رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر أغسطس 26, 2020 مشاركة قام بنشر أغسطس 26, 2020 في اعتقادنا ان حروف اللغة العربية 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 1 رابط هذا التعليق شارك More sharing options...
كريم الامين قام بنشر أغسطس 26, 2020 الكاتب مشاركة قام بنشر أغسطس 26, 2020 ا ستاذنا الرائع والطيب الاستاذ سليم المحترم كلامكم عين الصواب (أ , إ , ا ,آ ) اضافة الى( ى )هذا كله يعتبر حرف واحد من الاحرف ال 28 وهو حرف ا وكذلك نفس الشيئ (ت.ة )يعتبر حرف واحد وكذلك و ؤ حرف (واحد ) ارجو ان اكون قد وفقت بتوضيح الطلب جزاكم الله خيرا الحروف العربية.xlsx رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر أغسطس 26, 2020 أفضل إجابة مشاركة قام بنشر أغسطس 26, 2020 ربما يكون المطلوب 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 2 رابط هذا التعليق شارك More sharing options...
كريم الامين قام بنشر أغسطس 26, 2020 الكاتب مشاركة قام بنشر أغسطس 26, 2020 تمام استاذ احسنتم وشكرا لجهودكم هذا هو المطلوب وفقكم الله لكل خير الحقيقة الاستاذ سليم يستحق مليون اعجاب ليس فقط لانه استجاب لطلبي بارك الله فيه ولكن لانه سباق في تقديم يد العون لكل الاخوة ولكن للاسف لم انتبه لوجود زر الاعجاب 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان