اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

معرفة اذا كان رقم الهوية صادرة لأكثر من شخص


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

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

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

Option Explicit

Sub get_uniq()
Dim B As Worksheet, K As Worksheet
Dim x%, RG_A As Range, RG_E As Range
Dim i%, st$
Dim m%: m = 2
Application.ScreenUpdating = False
Set B = Sheets("البيانات"): Set K = Sheets("الخلاصة")
Set RG_A = K.Range("A2", Range("A1").End(4))
K.Range("F2", Range("F1").End(4)).ClearContents
B.Select
Set RG_E = B.Range("E2", Range("E1").End(4))
K.Select
i = 1
 Do Until RG_A.Cells(i) = vbNullString
  If Application.CountIf(RG_E, RG_A.Cells(i)) > 0 Then
             x = 1
             Do
                 If RG_A.Cells(i) = RG_E.Cells(x) Then
                  st = st & RG_E.Cells(x).Offset(, 1) & "+"
                 End If 'st
                  x = x + 1
                 If x > RG_E.Rows.Count Then Exit Do
             Loop
        If st <> vbNullString Then _
        K.Cells(m, "F") = Mid(st, 1, Len(st) - 1)
    End If 'error
     m = m + 1: i = i + 1: st = vbNullString
 Loop
 Application.ScreenUpdating = True
End Sub

الملف مرفق

 

tekrar names.xlsm

  • Like 1
رابط هذا التعليق
شارك

يرحم والديك

تمام 100 %

مشكور استاذ

فقط شغلة واحدة

ممكن عدم تكرار الاسم وجعله مرة واحدة ، فمثلاً : اذا فرضنا الرقم ذكر ثلاث مرات لنفس الشخص ، المطلوب عدم ذكر الاسم ثلاث مرات بل مرة واحدة

وكما موضح بالملف المرفق

 

ذكر الاسم مرة واحدة.xlsm

رابط هذا التعليق
شارك

  • أفضل إجابة

تعديل على الماكرو ليتناسب مع ما تريد

Option Explicit

Sub get_uniq_BY_collection()
Dim B As Worksheet, K As Worksheet
Dim x%, RG_A As Range, RG_E As Range
Dim i%, col As New Collection
Dim m%: m = 2
Dim st$, Itm
Application.ScreenUpdating = False
Set B = Sheets("البيانات"): Set K = Sheets("الخلاصة")
Set RG_A = K.Range("A2", Range("A1").End(4))
K.Range("F2", Range("F1").End(4)).ClearContents
B.Select
Set RG_E = B.Range("E2", Range("E1").End(4))
K.Select
i = 1
 Do Until RG_A.Cells(i) = vbNullString
  If Application.CountIf(RG_E, RG_A.Cells(i)) > 0 Then
             x = 1
             Do
                 If RG_A.Cells(i) = RG_E.Cells(x) Then
                 On Error Resume Next
                  col.Add RG_E.Cells(x).Offset(, 1).Value, _
                  RG_E.Cells(x).Offset(, 1)
                 End If 'col
                  x = x + 1
                  
                 If x > RG_E.Rows.Count Then Exit Do
             Loop
             On Error GoTo 0
         If col.Count > 0 Then
            For Each Itm In col
                st = st & Itm & "+"
            Next Itm
         End If
         If st <> vbNullString Then _
         K.Cells(m, "F") = Mid(st, 1, Len(st) - 1)
    End If 'error
     m = m + 1: i = i + 1
     Set col = New Collection
     st = vbNullString
 Loop
 Application.ScreenUpdating = True
End Sub

الملف من جديد

Only One_time.xlsm

  • Like 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information