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

إخواني وأحبابي في الله

اليوم أقدم لكم موضوع في غاية الأهمية لكثير من الأعضاء ، وهو كيفية اكتشاف الأسماء العربية الخاطئة.

فكرة الكود تعتمد على فكرة استخدام التصحيح اللغوي الموجود في برامج الأوفيس ، وبشكل افتراضي يعتمد التصحيح على اللغة الإنجليزية ، لذا في أول الأمر نقوم بضبط هذا الأمر بتنصيب حزمة اللغة العربية من خلال الرابط التالي
https://support.microsoft.com/en-us/office/install-the-arabic-language-pack-for-32-bit-office-920a3905-1fde-4f65-88bd-25818f3d76cb?ui=en-us&rs=en-us&ad=us

ثم بعد التنصيب نذهب لخيارات الإكسيل Excel Options ثم التبويب Language ثم نطبق الخيارات كما بالصورة لنجعل التصحيح اللغوي يخص اللغة العربية



نأتي لفكرة الكود وخوارزمية الحل
فكرة الكود أن يتم عمل حلقة تكرارية لكل الأسماء الموجودة في العمود الأول ، ثم نقوم بتقسم الاسم بناءً على المسافات بحيث نقوم باستخراج كل الأسماء وأثناء التقسيم يتم الفحص اللغوي للكلمة فإذا كانت الكلمة خاطئة يتم تخزينها في متغير القاموس ، واستخدام القاموس لنتجنب تخزين نفس الخطأ مرة أخرى ، كما يتم تلوين الخلية التي بها جزء من الاسم خطأ ، كما يتم وضع كل الأسماء الخاطئة التي تم اكتشافها في العمود الثاني

استراتيجية العمل
بفرض أن لديك ورقة العمل فيها الأسماء باللغة العربية والأسماء تبدأ من الخلية A2 لذا نقوم بالإعلان عن متغير من النوع Range لتخزين النطاق ليشمل كل الأسماء في العمود الأول ابتداءً من الخلية A2 وحتى آخر صف به بيانات ، ثم تخزين قيم النطاق في مصفوفة ليكون العمل أسرع.



يتم إزالة الألوان من النطاق قبل بدء بقية الخطوات ، ثم استخدام المتغير dic لاستخدامه ككائن للقاموس (الهدف من استخدامه عدم تكرار تخزين الخطأ .. بمعنى آخر إذا كان هنا خطأ فأول مرة يتم تخزينه وبعد ذلك إذا حدث نفس الخطأ لا يتم تخزينه)
تحديد القاموس الذي نرغب في التعامل معه وهو قاموس اللغة العربية

Application.SpellingOptions.DictLang = 3073<br />

بعد ذلك نقوم بعمل حلقة تكرارية لكل اسم ويتم تقسيم الاسم وفحص كل جزء من أجزاء الاسم للتأكد من أنه صحيح لغوياً فإذا كان هناك خطأ يتم تخزين القيمة الخاطئة ، ويتم تلوين الخلية التي بها الخطأ.
وفي نهاية المطاف يتم وضع الأسماء الخاطئة في العمود الثاني.

وبعد تنفيذ الكود سيكون شكل النتائج بهذا الشكل




إليكم الكود المستخدم لتنفيذ المهمة

Sub Extract_Invalid_Arabic_Names_Application_CheckSpelling()
    Dim a, x, rng As Range, dic As Object, f As Boolean, i As Long, j As Long
    Application.ScreenUpdating = False
        Set rng = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        rng.Interior.Color = xlNone
        a = rng.Value
        Set dic = CreateObject("Scripting.Dictionary")
        dic.CompareMode = 1
        Application.SpellingOptions.DictLang = 3073
        For i = LBound(a) To UBound(a)
            f = False
            x = Split(a(i, 1))
            For j = LBound(x) To UBound(x)
                If x(j) <> "" Then
                    If Not Application.CheckSpelling(Word:=CStr(x(j))) Then
                        dic.Item(x(j)) = Empty: f = True
                    End If
                End If
            Next j
            If f Then Cells(i + 1, 1).Interior.Color = vbCyan
        Next i
        a = dic.Keys
        With Range("B1")
            .Value = "Invalid Names"
            .Offset(1).Resize(UBound(a, 1) + 1).Value = Application.Transpose(a)
        End With
    Application.ScreenUpdating = True
End Sub

تحميل الملف المرفق من هنا

كان معكم أخوكم في الله / ياسر خليل أبو البراء