معادلة بحث وترتيب الاسماء

M.Elmahmoudy · السبت at 09:53

السلام عليكم

لو سمحتم محتاج معادلة بحص والشرح موجود داخل الملف

مع جزيل الشكر

**محمد هشام.** · السبت at 22:11

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

أخي @M.Elmahmoudy رغم أن طلبك غير واضح تماما بالنسبة لي لاكن بعد معاينة الملف على حسب ما فهمت أعتقد أن الحل الأمثل لتنفيد طلبك هو إستخدام الأكواد لأنها سوف تضمن لك الدقة في النتائج والسرعة في التنفيد

لأن المعادلات غير قادرة على تنفيذ جميع الوظائف بنفس الكفاءة خصوصا عند التعامل مع قوائم غير مرتبة وتكرار القيم ونطاقات غير المتساوية ولا ربما صفوف مخفية عند تنفيد الفرز على عمود معين زيادة على بطئ ملحوظ في الأداء عند وجود بيانات كبيرة

يمكنك تجربة هدا وإذا كنت بحاجة إلى أي تعديلات إضافية يمكنني محاولة مساعدتك في ذلك

Option Explicit
Sub Extract_Names()
    Dim dict As Object, début As Long, lr As Long, tmp As Range, AutoFilterWasOn As Boolean
    Dim dCount As Long, UniCount As Long, ColA As Range, ColB As Range
    
    Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2")

    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual
    End With
    AutoFilterWasOn = CrWS.AutoFilterMode
    If AutoFilterWasOn Then CrWS.AutoFilterMode = False
    lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _
                                           CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row)

    Set dict = CreateObject("Scripting.Dictionary")
    Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr)

    For Each tmp In ColB
        If Not dict.exists(tmp.Value) Then dict.Add tmp.Value, tmp.Row
    Next tmp

    CrWS.Range("C2:C" & CrWS.Cells(CrWS.Rows.Count, 3).End(xlUp).Row).ClearContents

    début = 3:   dCount = 0:   UniCount = 0

    For Each tmp In ColA
        If dict.exists(tmp.Value) Then
            CrWS.Cells(début, 3).Value = tmp.Value & " / " & CrWS.Cells(dict(tmp.Value), 2).Value
            dict.Remove tmp.Value
            début = début + 1
            dCount = dCount + 1
        End If
    Next tmp
    For Each tmp In ColB
        If dict.exists(tmp.Value) Then
            CrWS.Cells(début, 3).Value = tmp.Value
            début = début + 1
            UniCount = UniCount + 1
        End If
    Next tmp

    CrWS.Range("C2").Value = " عدد الوظائف  / المتشابهة: " & dCount & "  &   الفردية: " & UniCount
    CrWS.Columns("C:C").EntireColumn.AutoFit
    Set dict = Nothing

    With Application
        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
    End With
End Sub

Book2 v2.xlsb

M.Elmahmoudy · السبت at 22:24

اشكر لحضرتك مجهودك الرائع ، ولاكن سامحني لعدم التوضيح بشكل كافي

وقمت بالتوضيح في الملف المرفق

Book2 v21.xlsx

**محمد هشام.** · الأحد at 05:00

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

Capture.PNG.6f37e2a0278bbf1074334ee4a655e940.PNG

إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض

Option Explicit

Sub Extract_Names()
    Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean
    Dim Ons As Object, tbl As String, dict As Object, _
        début As Long, lr As Long, tmp As Range, Key As Variant
    
    
    Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2")
    With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
    
    AutoFilterWasOn = CrWS.AutoFilterMode
    If AutoFilterWasOn Then CrWS.AutoFilterMode = False
    
    lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _
                                           CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row)

    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Set Ons = CreateObject("Scripting.Dictionary")
    Ons.CompareMode = vbTextCompare
    
    For Each tmp In CrWS.Range("B3:B" & lr)
        If Not IsEmpty(tmp.Value) Then
            tbl = Replace(Trim(tmp.Value), " ", "")
            If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row
            If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row
        End If
    Next tmp

    CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents
    début = 3: dCount = 0: UniCount = 0
    For Each tmp In CrWS.Range("A3:A" & lr)
        If Not IsEmpty(tmp.Value) Then
            tbl = Replace(Trim(tmp.Value), " ", "")
            If dict.exists(tbl) Then
                CrWS.Cells(début, 4).Value = tmp.Value
                CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value
                dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1
            End If
        End If
    Next tmp
    
    For Each Key In Ons.keys
        CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value
        début = début + 1: UniCount = UniCount + 1
    Next Key
    
    CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount
    CrWS.Columns("D:E").AutoFit
    
    With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
End Sub

Book2 v3.xlsb

M.Elmahmoudy · بالامس في 14:11

On 3/30/2025 at 8:00 AM, محمد هشام. said:

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

إدا كنت تعتبر أنها أسماء متشابهة يجب جلبها أمام بعضها البعض فالكود التالي ربما سيوفي بالغرض

Option Explicit

Sub Extract_Names()
    Dim dCount As Long, UniCount As Long, AutoFilterWasOn As Boolean
    Dim Ons As Object, tbl As String, dict As Object, _
        début As Long, lr As Long, tmp As Range, Key As Variant
    
    
    Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2")
    With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
    
    AutoFilterWasOn = CrWS.AutoFilterMode
    If AutoFilterWasOn Then CrWS.AutoFilterMode = False
    
    lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _
                                           CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row)

    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Set Ons = CreateObject("Scripting.Dictionary")
    Ons.CompareMode = vbTextCompare
    
    For Each tmp In CrWS.Range("B3:B" & lr)
        If Not IsEmpty(tmp.Value) Then
            tbl = Replace(Trim(tmp.Value), " ", "")
            If Not dict.exists(tbl) Then dict.Add tbl, tmp.Row
            If Not Ons.exists(tbl) Then Ons.Add tbl, tmp.Row
        End If
    Next tmp

    CrWS.Range("D2:E" & CrWS.Rows.Count).ClearContents
    début = 3: dCount = 0: UniCount = 0
    For Each tmp In CrWS.Range("A3:A" & lr)
        If Not IsEmpty(tmp.Value) Then
            tbl = Replace(Trim(tmp.Value), " ", "")
            If dict.exists(tbl) Then
                CrWS.Cells(début, 4).Value = tmp.Value
                CrWS.Cells(début, 5).Value = CrWS.Cells(dict(tbl), 2).Value
                dict.Remove tbl: Ons.Remove tbl: début = début + 1: dCount = dCount + 1
            End If
        End If
    Next tmp
    
    For Each Key In Ons.keys
        CrWS.Cells(début, 5).Value = CrWS.Cells(Ons(Key), 2).Value
        début = début + 1: UniCount = UniCount + 1
    Next Key
    
    CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount
    CrWS.Columns("D:E").AutoFit
    
    With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
End Sub

Book2 v3.xlsb 38.99 kB · 6 downloads

جزاك الله خير استاذي الغالي

عمل رائع وشاكر افضالك

**محمد هشام.** · بالامس في 15:17

العفو أخي الكريم يسعدنا أننا إستطعنا مساعدتك

إليك طريقة أخرى مع إظافة التنسيقات يمكنك إختيار ما يناسبك

Option Explicit

Sub Extract_Names2()
    Dim dict As Object, ColA As Range, ColB As Range, a As Variant, b As Variant
    Dim tbl As String, Key As Variant, ColE As Long, début As Long, lr As Long, tmp As Range
    Dim dCount As Long, UniCount As Long, i As Long, Irow As Long, AutoFilterWasOn As Boolean
    
    Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2")
    
    With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With
    
    AutoFilterWasOn = CrWS.AutoFilterMode
    If AutoFilterWasOn Then CrWS.AutoFilterMode = False

    lr = Application.WorksheetFunction.Max(CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row, _
                                          CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row)

    With CrWS.Range("D2:E" & CrWS.Rows.Count)
        .ClearContents: .Borders.LineStyle = xlNone
    End With

    Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare
    Set ColA = CrWS.Range("A3:A" & lr): Set ColB = CrWS.Range("B3:B" & lr)

    For Each tmp In ColB
        tbl = tmp.Value
        If Not dict.exists(tbl) Then dict.Add tbl, 1 Else dict(tbl) = dict(tbl) + 1
    Next tmp

    début = 3: dCount = 0
    For Each tmp In ColA
        tbl = tmp.Value
        If dict.exists(tbl) Then
            CrWS.Cells(début, 4).Value = tbl
            CrWS.Cells(début, 5).Value = tbl
            dict.Remove tbl: début = début + 1: dCount = dCount + 1
        End If
    Next tmp

    ColE = Application.WorksheetFunction.Max(début, CrWS.Cells(Rows.Count, 5).End(xlUp).Row + 1)
    UniCount = 0
    For Each Key In dict.Keys
        CrWS.Cells(ColE, 5).Value = Key
        ColE = ColE + 1: UniCount = UniCount + 1
    Next Key

    CrWS.Range("D2").Value = "عدد الوظائف المتشابهة: " & dCount & " | عدد الوظائف الفردية: " & UniCount
    CrWS.Columns("D:E").AutoFit

    On Error Resume Next
    CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count).FormatConditions.Delete
    On Error GoTo 0

    With CrWS.Range("D3:E" & CrWS.UsedRange.Rows.Count)
        .FormatConditions.Add Type:=xlExpression, _
         Formula1:="=AND(D3<>"""", COUNTIF($D$3:$E$" & .Rows.Count & ", D3)>1)"
        .FormatConditions(1).Font.Color = RGB(255, 0, 0): .FormatConditions(1).Interior.Color = RGB(255, 182, 193)
    End With

    Irow = Application.WorksheetFunction.Max( _
        CrWS.Cells(CrWS.Rows.Count, "D").End(xlUp).Row, CrWS.Cells(CrWS.Rows.Count, "E").End(xlUp).Row)

a = CrWS.Range("D3:D" & Irow).Value: b = CrWS.Range("E3:E" & Irow).Value
For i = 1 To UBound(a, 1)
    If a(i, 1) <> "" Then
        With CrWS.Cells(i + 2, 4).Borders
             .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic
         End With
        End If
    If b(i, 1) <> "" Then
        With CrWS.Cells(i + 2, 5).Borders
           .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic
        End With
       End If
    Next i
    
  With Application: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: End With
  
End Sub

Book2 v4.xlsb

تم تعديل بالامس في 15:36 بواسطه محمد هشام.

تسجيل الدخول

معادلة بحث وترتيب الاسماء

الردود الموصى بها

M.Elmahmoudy

محمد هشام.

M.Elmahmoudy

محمد هشام.

M.Elmahmoudy

محمد هشام.

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information