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

[خالد ابوعوف]

السلام عليكم - حياكم الله

ملف يحتوي على شيت (البيانات ) وشيت (الخلاصة)

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

 

 

اكثر من شخص.xlsx

[ابو ايسل]

ارجو التوضيح اكثر انت عايز مايتمش تكرار ولا يتكرر بس تعرف انه اتكرر

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

هذه المعادلة

=IF(COUNTIF(البيانات!$E$2:$E$500,الخلاصة!A2)>1,"ERROR",VLOOKUP(الخلاصة!A2,البيانات!$E$1:$F$1500,2,0))

 

[Ali Mohamed Ali]

بعد اذن استاذنا الكبير سليم ولإثراء الموضوع يمكنك تجربة هذا

 

 

اكثر من شخص1.xlsx

[خالد ابوعوف]

 

 

جزيتم خيرا

 

ممكن اظهار الاسماء المكررة كما في الملف

اكثر من شخص1 - اظهار الاسماء المكررة.xlsx

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

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

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

[خالد ابوعوف]

يرحم والديك

تمام 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

[خالد ابوعوف]

جزيت خيرا

يرحم والديك

تسلم