أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
أحمد يوسف ali mohamed ali-- لا تميز خلال هذه الفترة YasserKhalil كود بسيط لمعرفة معلومات مهمه عن جهازك - حسام خطاب اكسيل اسئله واجابات


اعلان هنا
ألعاب فلاش أون لاين
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا



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





ما هى الاضافة للحصول على قيم غير مكرر

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريبالسلام عليكم ارجو تعديل الكود للحصول على قيم فريده ما يهمنى فى عد ..



24-10-2019 11:21 مساء
سعد عابد
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 87
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
يتابعهم : 4
يتابعونه : 1
قوة السمعة : 102
الاعجاب : 16
 offline 

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريبالسلام عليكم
ارجو تعديل الكود للحصول على قيم فريده
ما يهمنى فى عدم التكرار هو الرقم وليس الاسم 
اشكركم
Sub car_spicial_name()
    Application.ScreenUpdating = False
    On Error Resume Next
    Dim ws, sh As Worksheet
    Dim a As Variant
    Dim i, p, y As Long
      Set sh = data12: Set ws = data2
    '===============================================================================
       ''''''''''''''''''''''''''''''''''=====================================================
    a = ws.Range("a5:o" & ws.Cells(Rows.Count, 2).End(xlUp).Row)
        p = sh.Range("c" & Rows.Count).End(xlUp).Row + 3
        For y = 1 To UBound(a, 1)
            If a(y, 2) = sh.Range("i1").Value Then
                sh.Range("b" & p) = sh.Range("i1").Value
                sh.Range("c" & p).Value = a(y, 3)
                p = p + 1
            End If
        Next
        End Sub
 
 
  sort5.rar   تحميل rar مرات التحميل :(6)
الحجم :(140.237) KB







25-10-2019 09:11 صباحا
مشاهدة مشاركة منفردة [1]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 430
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 17
قوة السمعة : 3401
الاعجاب : 294
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
جرب هذا الماكرو

Option Explicit
Sub Get_Uniques()
Dim MY_DIC As Object
Dim K, m, x%: x = 5
Dim Res As Worksheet
Dim dat As Worksheet
Set Res = Sheets("result"): Set dat = Sheets("data1")
Set MY_DIC = CreateObject("Scripting.Dictionary")
 Res.Range("B4").CurrentRegion.Offset(1).ClearContents
With MY_DIC
    Do Until dat.Range("B" & x) = vbNullString
        K = dat.Range("C" & x): m = dat.Range("B" & x)
            If Not .Exists(K) Then
               .Add K, m
            End If
             x = x + 1
     Loop
       Res.Range("B5").Resize(.Count) = _
        Application.Transpose(.Items)
       Res.Range("C5").Resize(.Count) = _
        Application.Transpose(.Keys)
    .RemoveAll: Set MY_DIC = Nothing
End With
End Sub

الملف مرفق
 
 
  sorting_5.rar   تحميل rar مرات التحميل :(4)
الحجم :(92.818) KB


أثارت هذه المشاركة إعجاب: YasserKhalil، سعد عابد،




25-10-2019 09:36 صباحا
مشاهدة مشاركة منفردة [2]
سعد عابد
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 87
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
يتابعهم : 4
يتابعونه : 1
قوة السمعة : 102
الاعجاب : 16
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
اخى سليم
جمعتكم مباركة
اسال الله العظيم ان يبارك فيك 
جزاك الله خير
هذا هو المطلوب
ولى سؤال اخى 
1- هل ممكن اضافة صفين اذا تغير الاسم  لانى ساعمل جمع فرعى
انا منفذها بس بطريقة بتاخد وقت
2- هل ممكن الاسم يذكر مره واحده (item) ثم يذكر (keys) التابع له





25-10-2019 09:42 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8167
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23793
الاعجاب : 2466
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
بارك الله فيك أخي العزيز سعد

هل التكرار في الرقم مرتبط بالتكرار في الاسم ..؟
أقصد هل تريد إزالة التكرار في الرقم حتى لو كان الرقم مرتبط باسم آخر..؟؟

لتوضيح سؤالي بشكل آخر وبمثال:
في المرفق يوجد الرقم 1632 مرتبط باسم saad ومرتبط باسم gg
ما المتوقع في النتائج ؟؟ أن تحصل على الرقم 1632 مرة واحدة فقط (وفي هذه الحالة ما الاسم الذي سيكون مرتبط بالرقم؟) أم تريد أن يتم إدراج كلا الاسمين رغم ارتباطهما بنفس الرقم

يرجى أن يكون الملف المرفق معبر عن الملف الأصلي

أثارت هذه المشاركة إعجاب: سعد عابد،




25-10-2019 09:55 صباحا
مشاهدة مشاركة منفردة [4]
سعد عابد
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 87
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
يتابعهم : 4
يتابعونه : 1
قوة السمعة : 102
الاعجاب : 16
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
اخى ياسر سلام الله عليكم ورحمته وبركاته
سؤالك هام جدا
نعم اريد ذكر الرقم مع كل اسم كرر معه الرقم
اشكرك على هذا السؤال
========================
بمعنى اخر الاسم هو الاساس
سعد يتبعه عدة ارقام حتى لو كرر مع غيره يذكر ما دام ذكر امامه
 





25-10-2019 10:10 صباحا
مشاهدة مشاركة منفردة [5]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 430
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 17
قوة السمعة : 3401
الاعجاب : 294
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
تم التعديل كما تريد

Option Explicit
Sub Get_Uniques()
Dim MY_DIC As Object
Dim K, m, x%: x = 5
Dim Res As Worksheet
Dim dat As Worksheet
Set Res = Sheets("result"): Set dat = Sheets("data1")
Set MY_DIC = CreateObject("Scripting.Dictionary")
 Res.Range("B4").CurrentRegion.Offset(1).ClearContents
With MY_DIC
    Do Until dat.Range("B" & x) = vbNullString
        K = dat.Range("C" & x): m = dat.Range("B" & x)
            If Not .Exists(K) Then
               .Add K, m
            End If
             x = x + 1
     Loop
       Res.Range("B5").Resize(.Count) = _
        Application.Transpose(.Items)
       Res.Range("C5").Resize(.Count) = _
        Application.Transpose(.Keys)
    .RemoveAll: Set MY_DIC = Nothing
End With
remove_dup
End Sub
'++++++++++++++++++++++++++++++++++
Sub remove_dup()
Dim i%, how_many%
Dim lrB%: lrB = Sheets("result").Cells(Rows.Count, 2).End(3).Row
If lrB < 5 Then Exit Sub

 For i = 5 To lrB
   how_many = Application.CountIf(Range("b5:b" & i), Range("b" & i))
    If how_many > 1 Then Range("b" & i) = vbNullString
  Next
End Sub

 
 
  sorting_5_new.rar   تحميل rar مرات التحميل :(4)
الحجم :(94.986) KB


أثارت هذه المشاركة إعجاب: سعد عابد، ali mohamed ali،




25-10-2019 10:11 صباحا
مشاهدة مشاركة منفردة [6]
سعد عابد
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 87
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
يتابعهم : 4
يتابعونه : 1
قوة السمعة : 102
الاعجاب : 16
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
بعد مراجعه كود اخى سليم
يعمل بكفاءة لكنه يذكر الرقم مره واحده مع اسم واحد
فى gg لم يذكر رقم 1632 وايضا 9254





25-10-2019 10:18 صباحا
مشاهدة مشاركة منفردة [7]
سعد عابد
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 12
المشاركات : 87
الجنس : ذكر
تاريخ الميلاد : 17-1-1968
يتابعهم : 4
يتابعونه : 1
قوة السمعة : 102
الاعجاب : 16
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
اخى سليم 
اشكرك كل الشكر على مجهودك معى
باقى مشكلة وحيده وهى 
ان الرقم من الممكن ان يذكر مع اكثر من اسم 
فهل لها حل انا اريد الاسم بارقامه حتى لو تكرر مع اسم اخر
اشكركم 





25-10-2019 08:04 مساء
مشاهدة مشاركة منفردة [8]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8167
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23793
الاعجاب : 2466
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
أعتذر عن عدم المشاركة حيث أن الكهرباء غير مستقرة وكذلك الاتصال بالانترنت ...

أثارت هذه المشاركة إعجاب: سعد عابد،




25-10-2019 11:36 مساء
مشاهدة مشاركة منفردة [9]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 430
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 17
قوة السمعة : 3401
الاعجاب : 294
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
تم التعديل مرة اخرى

Option Explicit
Sub best_code()
Application.ScreenUpdating = False
Dim dat As Worksheet
Dim res As Worksheet
Dim ro#, my_max#

Set dat = Sheets("data1"): Set res = Sheets("result")
ro = dat.Range("A4").CurrentRegion.Rows.Count
res.Range("A4").CurrentRegion.Offset(1).ClearContents

dat.Range("G5").Resize(ro - 1).Formula = _
"=IF(SUMPRODUCT(--(B5&C5=$B$5:B5&$C$5:C5))=1,MAX($G$4:G4)+1,"""")"
my_max = Application.Max(dat.Range("G5").Resize(ro - 1))

With res.Range("C5").Resize(my_max)
    .Formula = _
        "=INDEX(data1!$C$5:$C$100,MATCH(ROWS($A$1:A1),data1!$G$5:$G$100,0))"
    .Value = .Value
       With .Offset(, -1)
         .Formula = _
        "=INDEX(data1!$B$5:$B$100,MATCH(ROWS($A$1:A1),data1!$G$5:$G$100,0))"
        .Value = .Value
       End With
End With
dat.Range("G5").Resize(ro - 1).Clear
remove_dup
Application.ScreenUpdating = True
End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++
Sub remove_dup()
 Dim i#, how_many#
Dim lrB%
 With Sheets("result")
 lrB = .Cells(Rows.Count, 2).End(3).Row
 If lrB < 5 Then Exit Sub
 For i = 5 To lrB
   how_many = Application.CountIf(.Range("B5:B" & i), .Range("b" & i))
    If how_many > 1 Then .Range("B" & i) = vbNullString
  Next
  End With
End Sub

الملف من جديد
 
 
 
  sorting-new.rar   تحميل rar مرات التحميل :(4)
الحجم :(96.256) KB


أثارت هذه المشاركة إعجاب: ali mohamed ali، YasserKhalil، سعد عابد،




26-10-2019 02:49 صباحا
مشاهدة مشاركة منفردة [10]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8167
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23793
الاعجاب : 2466
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
أخي الكريم سعد

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

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

أثارت هذه المشاركة إعجاب: سعد عابد،




26-10-2019 06:39 صباحا
مشاهدة مشاركة منفردة [11]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 430
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 17
قوة السمعة : 3401
الاعجاب : 294
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
كلما ذهبت الى هذا الرابط تظهر معى هذه الرسالة
وانا بصراحة غير مطمئن لهذا الرابط
فرجاءا وضع الكود مباشرة هنا
lcS0N_Capt
 
 
 






26-10-2019 06:44 صباحا
مشاهدة مشاركة منفردة [12]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8167
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23793
الاعجاب : 2466
 offline 
look/images/icons/i1.gif ما هى الاضافة للحصول على قيم غير مكرر
لا تقلق أخي سليم
عموماً إليك الرابط المباشر للكود ..

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

أثارت هذه المشاركة إعجاب: سعد عابد، ali mohamed ali،





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
التنبيه برسالة في حالة التكرار مع الخيار بالاضافة او الالغاء عبدالله الصاري
19 1492 ahmed ghoneim
الاضافة من فورم الي كمبوكس رمضان بكري
8 1057 YasserKhalil
الحالة الغريبة عند الاضافة الي لست بوكس يظهر معك كود الصنف رمضان بكري
1 487 رمضان بكري

الكلمات الدلالية
الاضافة ، للحصول ، مكرر ،


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.



الساعة الآن 09:58 صباحا

أعلن هنا
أعلن هنا
أعلن هنا