إستخراج التشابه وفق معيارين

[أبو أنس حاجب]

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

المطلوب حفظكم الله

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

أبو أنس

استخراج التشابه.rar

[عبدالله المجرب]

السلام عليكم

جرب هذا الكود

Sub Abu_Ahmed()

Dim cl As Range

Application.ScreenUpdating = False

Set MySh = Sheets("Sheet2")

[K2:L300].ClearContents

MySh.[B6:C300].ClearContents

For i = 6 To [C10000].End(xlUp).Row

R = Mid(Cells(i, 3), InStr(Cells(i, 3), "(") + 1, Len(Mid(Cells(i, 3), (InStr(Cells(i, 3), "(") + 1), 10)) - 1)

T = Mid(Cells(i, 3), 1, InStr(Cells(i, 3), "(") - 1)

Range("K" & [K10000].End(xlUp).Row + 1) = T

Range("L" & [L10000].End(xlUp).Row + 1) = R

Next

For Each cl In Range("C6:C" & [C10000].End(xlUp).Row)

RR = Mid(cl, InStr(cl, "(") + 1, Len(Mid(cl, (InStr(cl, "(") + 1), 10)) - 1)

w = Application.CountIf([L2:L100], RR)

If Application.CountIf([L2:L100], RR) > 1 Then MySh.Range("C" & MySh.[C10000].End(xlUp).Row + 1) = cl

TT = Mid(cl, 1, InStr(cl, "(") - 1)

WW = Application.CountIf([K2:K100], TT)

If WW > 1 Then MySh.Range("B" & MySh.[B10000].End(xlUp).Row + 1) = cl

Next

[K2:L300].ClearContents

Set MySh = Nothing

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا أحمد (عبد الله المجرب) حفظك الله

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

عافاك الله ويسر لك سبل الخير والصلاح.

أبو أنس

[عبدالله المجرب]

هذا تعديل على الكود

Sub Abu_Ahmed()

Dim cl As Range

Application.ScreenUpdating = False

Set MySh = Sheets("Sheet2")

[K2:L300].ClearContents

MySh.[B6:C300].ClearContents

For i = 6 To [C10000].End(xlUp).Row

If InStr(Cells(i, 3), "(") = 0 Then GoTo 1

R = Mid(Cells(i, 3), InStr(Cells(i, 3), "(") + 1, Len(Mid(Cells(i, 3), (InStr(Cells(i, 3), "(") + 1), 10)) - 1)

T = Mid(Cells(i, 3), 1, InStr(Cells(i, 3), "(") - 1)

Range("K" & [K10000].End(xlUp).Row + 1) = T

Range("L" & [L10000].End(xlUp).Row + 1) = R

1 Next

For Each cl In Range("C6:C" & [C10000].End(xlUp).Row)

If InStr(cl, "(") = 0 Then GoTo 2

RR = Mid(cl, InStr(cl, "(") + 1, Len(Mid(cl, (InStr(cl, "(") + 1), 10)) - 1)

w = Application.CountIf([L2:L100], RR)

If Application.CountIf([L2:L100], RR) > 1 Then MySh.Range("C" & MySh.[C10000].End(xlUp).Row + 1) = cl

TT = Mid(cl, 1, InStr(cl, "(") - 1)

WW = Application.CountIf([K2:K100], TT)

If WW > 1 Then MySh.Range("B" & MySh.[B10000].End(xlUp).Row + 1) = cl

2 Next

[K2:L300].ClearContents

Set MySh = Nothing

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا أحمد حفظك الله

لقد أرسلت لك رسالة على الخاص

أبو أنس