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

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

أثناء تصفحي للفيس بوك بالأمس صادفني السؤال التالي



في الحقيقة الموضوع جذبني حيث أنه جديد ولم يطلبه أحد من قبل.
المشكلة تتمحور في أن الأسماء باللغة العربية يمكن كتابتها بأكثر من شكل ، وهذا ما يشكل المشكلة عند حدوث تكرار فمن الصعب معرفة التكرار لأن القيم تكون مختلفة حتى ولو كان الاختلاف مجرد مسافة (كما ذكر أخونا يوسف في السؤال [محمد سلطان] و[محمدسلطان] كلاهما نفس الاسم لكن الاسم الأول به مسافة بينما الاسم الثاني ليس به مسافة)

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

تأتي الخطوة الثانية في وضع كود يقوم باكتشاف المكرر ويضع رقم مختلف لكل مجموعة من الأسماء مكررة أي أن الكود سيقوم بعمل ما يشبه بالمجموعات ويعطي كل مجموعة رقم مختلف بحيث يقوم المستخدم بعمل فلتر على العمود الذي سيكون هو ناتج الكود ويختار المجموعة المطلوبة ليرى الأسماء المكررة)

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



نلاحظ على سبيل المثال الاسم محمد سلطان علي تم تكراره في الخلايا A2 و A5 و A8 بأشكال مختلفة ، وهذا الاسم بهذا الشكل في الثلاثة خلايا يشكل مجموعة (وسيكون اسم المجموعة Duplicate يليها مسافة ثم رقم المجموعة)

سيتم استخدام العمود الثاني لإظهار نتائج التكرار فيه ، والعمود الثالث سيكون عمود مساعد ستوضع فيه الأسماء بعد توحيد الاختلاف

وأخيراً إليكم الكود المستخدم في تنفيذ المطلوب ، ويوضع الكود في موديول عادي

Sub Find_Duplicate_Arabic_Names()
    Dim a, e, x(), dic As Object, cel As Range, arr() As String, lr As Long, i As Long, j As Long
    Application.ScreenUpdating = False
        a = Range("A1").CurrentRegion.Resize(, 3).Value
        Set dic = CreateObject("Scripting.Dictionary")
        For j = 2 To UBound(a)
            a(j, 3) = MyReplace(a(j, 1))
        Next j
        Range("A1").Resize(UBound(a, 1), UBound(a, 2)).Value = a
        lr = Cells(Rows.Count, 3).End(xlUp).Row
        With dic
            .CompareMode = vbTextCompare
            For Each cel In Range("C1:C" & lr)
                If Not .Exists(cel.Value) Then
                    .Item(cel.Value) = cel.Value & "^" & cel.Address(0, 0)
                Else
                    .Item(cel.Value) = Split(.Item(cel.Value), "^")(0) & " | " & cel.Value & "^" & Split(.Item(cel.Value), "^")(1) & " | " & cel.Address(0, 0)
                End If
            Next cel
            If .Count Then
                ReDim x(1 To .Count, 1 To 2)
                For Each e In .Keys
                    If InStr(.Item(e), "|") > 0 Then
                        i = i + 1
                        arr = Split(Split(.Item(e), "^")(1), "|")
                        For j = LBound(arr) To UBound(arr)
                            Set cel = Range(Trim(arr(j)))
                            Cells(cel.Row, cel.Column - 1).Value = "Duplicate " & CStr(i)
                        Next j
                    End If
                Next e
            End If
        End With
        Range("B1").Value = "Output"
        Columns(3).ClearContents
    Application.ScreenUpdating = True
End Sub

Function MyReplace(ByVal s As String) As String
    Dim a, b, e, i As Long
    a = Array(" ", ChrW(1571), ChrW(1573), ChrW(1570), ChrW(1609), ChrW(1577))
    b = Array("", ChrW(1575), ChrW(1575), ChrW(1575), ChrW(1610), ChrW(1607))
    For Each e In a
        s = Replace(s, a(i), b(i))
        i = i + 1
    Next e
    MyReplace = s
End Function

وهذا هو شكل ورقة العمل بعد تنفيذ الكود



نلاحظ أن كل مجموعة أسماء لها رقم مختلف ، لذا يسهل الآن عمل فلتر باسم المجموعة في العمود الثاني لمعرفة الأسماء المكررة.




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