المساعدة في استخراج الاسماء المتشابهة في الاسم والأول والثاني والثالث

[commandos1975]

 

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

Book1.xls

[سليم حاصبيا]

حرب هذا الماكرو

الاسماء في العامود A ابتداء من الخلية 2

Option Explicit
Sub extract()
Dim i%: i = 2
Dim x%, k%, t%
Dim m%: m = 1
Dim arr1, arr2, arr3()
Dim my_arr
Range("c:c").ClearContents
Do Until Range("a" & i) = vbNullString
arr1 = Split(Trim(Range("a" & i)), " ")
 If UBound(arr1) < 3 Then GoTo 1:
 For x = i + 1 To 6
  arr2 = Split(Trim(Range("a" & x)), " ")
  If UBound(arr2) < 3 Then GoTo 1:
  For k = 0 To 2
   If arr1(k) = arr2(k) Then
    ReDim Preserve arr3(t)
    arr3(t) = arr2(k)
    t = t + 1
    End If
   Next
  my_arr = Join(arr3, " ")
  If my_arr <> "" Then
    Range("c" & m) = my_arr
    my_arr = ""
 End If
 Erase arr3
  t = 0
1:
Next
i = i + 1
m = m + 1
Loop
End Sub

الملف مرفق

 

Booksalim.xls

[Ali Mohamed Ali]

احسنت استاذ سليم عمل رائع بارك الله فيك وجعله فى ميزان حسناتك

[commandos1975]

شكرا للغالي ولكن هل يمكن التلوين للخليه بدلا من الرحيل