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

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


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





إستخراج قائمة غير مكررة من الأسماء

السلام عليكم ورحمة الله وبركاته فى المرفقات شيت اكسل به عمودين العمود الاخضر به تكرار للاسماء والعمود الاحمر نفس الاسم ..


موضوع مغلق


16-11-2020 06:17 مساء
حبيبتى دائما
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 19-07-2019
رقم العضوية : 13887
المشاركات : 93
الجنس : ذكر
تاريخ الميلاد : 5-3-1984
يتابعهم : 9
يتابعونه : 0
قوة السمعة : 76
 offline 

السلام عليكم ورحمة الله وبركاته
فى المرفقات شيت اكسل به عمودين 
العمود الاخضر به تكرار للاسماء 
والعمود الاحمر نفس الاسماء ولكن بدون تكرار
ولكن المعادلات عند سحبها فى ملف العمل للصف 2000 الملف تقيل جدا وبياخد وقت للحساب واوقات بيهنج ويخرج من العمل
اريد عدم التكرار ولكن بالاكواد 
بحيث اى تغيير يطرأ او اسم جديد يتم كتابتة فى العمود الاخضر 
يظهر تلقائيا فى العمود الاحمر ان لم يكن موجود مسبقا
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
 
  إستخراج قائمة غير مكررة من الأسماء.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(21.677) KB



أفضل إجابة مقدمة من Eslam Abdullah وهي:
من غير اى زر ضع الكود دا فى الشيت اللى هيظهر فيه النتائج وبس
Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
Dim sh As Worksheet, lr&
Set sh = Sheets("sheet1")
lr = sh.Cells(Rows.Count, 1).End(3).Row
Range("A2").Resize(lr).Value = sh.Range("A1:A" & lr).Value
Range("A2").Resize(lr).RemoveDuplicates Columns:=1, Header:=xlYes
Application.ScreenUpdating = 1
End Sub
عرض الإجابة




16-11-2020 09:25 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif إستخراج قائمة غير مكررة من الأسماء
جرب هذا الكود

Sub find_Uniq()
    Dim SH1 As Worksheet, SH2 As Worksheet
    Dim L1%, L2%, K%
    Dim Obj As Object

    Set SH1 = Sheets("Sheet1")
    Set SH2 = Sheets("Sheet2")
    Set Obj = CreateObject("Scripting.Dictionary")

L1 = SH1.Cells(Rows.Count, 1).End(3).Row
L2 = SH2.Cells(Rows.Count, 1).End(3).Row

    If L2 > 1 Then
     SH2.Range("A1").CurrentRegion.Offset(1). _
     Resize(L2 - 1).ClearContents
    End If
K = 1

Do Until K = L1 + 1
 If SH1.Cells(K, 1) <> vbNullString Then
    Obj(SH1.Cells(K, 1).Value) = vbNullString
 End If
 K = K + 1
Loop
 
 If Obj.Count Then
   SH2.Cells(2, 1).Resize(Obj.Count).Value = _
   Application.Transpose(Obj.keys)
 End If
End Sub

الملف مرفق
 
 
  Uniquesname.xlsm   تحميل xlsm مرات التحميل :(8)
الحجم :(33.511) KB


16-11-2020 10:30 مساء
مشاهدة مشاركة منفردة [2]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif إستخراج قائمة غير مكررة من الأسماء
وعليكم السلام ورحمه الله وبركاته
تفضل جرب هذا الكود
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng, cel As Range, Coll As New Collection, i As Integer

    If Application.ActiveCell.Column = 1 Then
        Set Rng = Sheet1.Range("A1:A" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
        On Error Resume Next
        For Each cel In Rng
            Coll.Add cel.Value, CStr(cel.Value)
        Next cel
        For i = 1 To Coll.Count
            Sheet2.Cells(i + 1, 2).Value = Coll(i)
        Next i
    Else
    End If
End Sub


16-11-2020 10:39 مساء
مشاهدة مشاركة منفردة [3]
محمد أبو عبدو
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-08-2017
رقم العضوية : 247
المشاركات : 202
الجنس : ذكر
تاريخ الميلاد : 13-4-1966
يتابعهم : 6
يتابعونه : 2
قوة السمعة : 613
عدد الإجابات: 1
 offline 
look/images/icons/i1.gif إستخراج قائمة غير مكررة من الأسماء
أخي أتمنى أني قد أجبت على سؤالك
لم أتمكن من رفع الملف، لكن جرب هذا الكود:
Sub Data_Not_Duplicate()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Lr1 As Long, Lr2 As Long
Application.ScreenUpdating = False

Set Sh1 = ThisWorkbook.Sheets("Sheet1")
Set Sh2 = ThisWorkbook.Sheets("Sheet2")

Lr1 = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
Lr2 = Sh2.Cells(Rows.Count, 1).End(xlUp).Row

    With Sh1
    .Select
    .Range("A2:A" & Lr1).Select
    Selection.Copy
    .Range("A2").Select
    End With

    With Sh2
    .Select
    .Range("A" & Lr2 + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    .Range("A2:A" & Lr2 + Lr1 - 1).Select
    With Selection.Font
        .Name = "Arial"
        .Size = 16
    End With
    .Range("A2:A" & Lr2 + Lr1 - 1).RemoveDuplicates Columns:=1, Header:=xlNo
    .Range("A2").Select
    End With

Application.ScreenUpdating = True
End Sub




16-11-2020 11:52 مساء
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif إستخراج قائمة غير مكررة من الأسماء
[quote=محمد أبو عبدو]
أخي أتمنى أني قد أجبت على سؤالك
لم أتمكن من رفع الملف، لكن جرب هذا الكود:

صديقي محمد
الكود الذي رفعته جيد جداً لكن عندي ملاحظات
1- لا ضرورة لهذا الكم الهائل من الأوامر  Select & Copy
      التي ترهق البرنامج دون  جدوى لاننا نستطيع ان ننسخ
      (Copy)اي  Range دون الانتقال الى الـــ Sheet التي تحتويه ثم             نعمل  له Select كي ننسخه
2- اذا كنت تريد استعمل الـــ   RemoveDuplicates هذا الكود
     الذي لا يحتوي على اي أمر  Select & Copy أو Paste

Sub find_Uniq()
    Dim SH1 As Worksheet, SH2 As Worksheet
    Dim L1%, L2%

    Set SH1 = Sheets("Sheet1")
    Set SH2 = Sheets("Sheet2")
    L1 = SH1.Cells(Rows.Count, 1).End(3).Row
    L2 = SH2.Cells(Rows.Count, 1).End(3).Row
  With SH2
    .Range("A2:A" & L2).ClearContents
    .Range("A2").Resize(L1).Value = _
      SH1.Range("A1").Resize(L1).Value
    .Range("A2").Resize(L1).RemoveDuplicates _
    1, Header:=2
  End With
End Sub


 

17-11-2020 03:39 مساء
مشاهدة مشاركة منفردة [5]
Eslam Abdullah
مشرف على لغات برمجة آخرى
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 03-10-2017
رقم العضوية : 852
المشاركات : 1580
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 1-9-1995
الدعوات : 5
يتابعهم : 0
يتابعونه : 90
قوة السمعة : 10845
موقعي : زيارة موقعي
عدد الإجابات: 6
 offline 
look/images/icons/i1.gif إستخراج قائمة غير مكررة من الأسماء
من غير اى زر ضع الكود دا فى الشيت اللى هيظهر فيه النتائج وبس
Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
Dim sh As Worksheet, lr&
Set sh = Sheets("sheet1")
lr = sh.Cells(Rows.Count, 1).End(3).Row
Range("A2").Resize(lr).Value = sh.Range("A1:A" & lr).Value
Range("A2").Resize(lr).RemoveDuplicates Columns:=1, Header:=xlYes
Application.ScreenUpdating = 1
End Sub



الكلمات الدلالية
مكررة ، قائمة ، إستخراج ، الأسماء ،


 










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

الساعة الآن 06:18 مساء