رفع المكرر

[عبدالودود لطيف]

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

لطفاً اريد تصفية البيانات كما موضح بالملف المرفق

اظهار النتائج.rar

[ياسر خليل أبو البراء]

وعليكم السلام أخي الكريم

أهلاً بك في المنتدى

 

حدد النطاق G2:H11 في ورقة العمل المسماة "بيانات" .. انسخ النطاق والصقه في ورقة العمل المسماة "جدول" في الخلية G1 على سبيل المثال ..

اذهب للتبويب Data ستجد أمر اسمه Remove Duplicates انقر عليه وستظهر نافذة اضغط على OK .. وستحصل على المطلوب إن شاء الله

[الأستاذ / محمد الدسوقى]

بارك الله فيك استاذ الغالى ياسر أبو البراء

لو أمكن وضع هذه الخطوات فى كود لتسهيل العملية وزيادة نطاق الفلترة

 

Sub Data_Filter()
Application.ScreenUpdating = False

    Sheets("بيانات").Select
    Range("G1:H1000").Select
    Selection.Copy
    Sheets("جدول").Select
    Range("G2").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$G$1:$H$1000").RemoveDuplicates Columns:=Array(1, 2), Header _
        :=xlNo
    Range("A1").Select
    
 Application.ScreenUpdating = True
   
    
End Sub

 

[عبدالودود لطيف]

السلام عليكم : تقصد أستاذ ياسر - إزالة التكرارات

كود أستاذ محمد - ممتاز وسهل ، ولكن عذرا أخطأت في المثال المرفق ، سوف ارفق مثال جديد - اعتذر

ممكن معادلة تظهر النتائج كما مبينة بالمثال المرفق - مع تعديل الكود

اظهار النتائج1.rar

تم تعديل أغسطس 4, 2017 بواسطه عبدالوود لطيف

[ياسر خليل أبو البراء]

وعليكم السلام

تفضل أخي كود بسيط جداً ومفهوم ... بالطريقة العادية 

Sub DeleteDuplicatesFromTwoColumns()
    Dim ws As Worksheet
    Dim sh As Worksheet
    Dim rng As Range
    
    Application.ScreenUpdating = False
        Set ws = Sheets("بيانات")
        Set sh = Sheets("جدول")
        
        With sh
            Set rng = ws.Range("G1:K" & ws.Cells(Rows.Count, "G").End(xlUp).Row)
            rng.Copy .Range("G1")
            .Range("G1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 5), Header:=xlNo
            .Columns("H:J").Delete
            .Columns(8).Cut: .Columns(7).Insert Shift:=xlToRight
            .Range("G2:H" & .Cells(Rows.Count, "G").End(xlUp).Row).Copy
            .Range("A2").PasteSpecial xlPasteValues
            .Columns("G:H").Clear
            Application.CutCopyMode = False
        End With
    Application.ScreenUpdating = True
End Sub

 

وإذا أردت كود متقدم فتفضل الكود التالي .. حيث التعامل يكون بعيد عن التعامل مع ورقة العمل بشكل مباشر ..

Sub UniqueFromTwoColumns()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim arr     As Variant
    Dim e       As Variant
    Dim i       As Long

    Set ws = Sheets("بيانات")
    Set sh = Sheets("جدول")
    arr = ws.Range("G1:K" & ws.Cells(Rows.Count, "G").End(xlUp).Row).Value

    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(arr)
            .Item(arr(i, 5) & "," & arr(i, 1)) = .Item(arr(i, 5) & "," & arr(i, 1))
        Next i

        i = 2
        sh.Range("A1:B1").Value = Array("الكود", "الاسم")
        For Each e In .keys
            sh.Cells(i, "A").Resize(, 2) = Split(e, ",")
            i = i + 1
        Next e
    End With
End Sub

 

[عبدالودود لطيف]

اشكرك استاذ

الحمد لله كود شغال وسهل - احسن الله اليك

[ياسر خليل أبو البراء]

الحمد لله أن تم المطلوب على خير والحمد لله الذي بنعمته تتم الصالحات

تقبل تحياتي

[عبدالودود لطيف]

اشكرك استاذ

[محمود أبوالدهب]

7 ساعات مضت, ياسر خليل أبو البراء said:

وعليكم السلام

تفضل أخي كود بسيط جداً ومفهوم ... بالطريقة العادية 

Sub DeleteDuplicatesFromTwoColumns()
    Dim ws As Worksheet
    Dim sh As Worksheet
    Dim rng As Range
    
    Application.ScreenUpdating = False
        Set ws = Sheets("بيانات")
        Set sh = Sheets("جدول")
        
        With sh
            Set rng = ws.Range("G1:K" & ws.Cells(Rows.Count, "G").End(xlUp).Row)
            rng.Copy .Range("G1")
            .Range("G1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 5), Header:=xlNo
            .Columns("H:J").Delete
            .Columns(8).Cut: .Columns(7).Insert Shift:=xlToRight
            .Range("G2:H" & .Cells(Rows.Count, "G").End(xlUp).Row).Copy
            .Range("A2").PasteSpecial xlPasteValues
            .Columns("G:H").Clear
            Application.CutCopyMode = False
        End With
    Application.ScreenUpdating = True
End Sub

 

وإذا أردت كود متقدم فتفضل الكود التالي .. حيث التعامل يكون بعيد عن التعامل مع ورقة العمل بشكل مباشر ..

Sub UniqueFromTwoColumns()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim arr     As Variant
    Dim e       As Variant
    Dim i       As Long

    Set ws = Sheets("بيانات")
    Set sh = Sheets("جدول")
    arr = ws.Range("G1:K" & ws.Cells(Rows.Count, "G").End(xlUp).Row).Value

    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(arr)
            .Item(arr(i, 5) & "," & arr(i, 1)) = .Item(arr(i, 5) & "," & arr(i, 1))
        Next i

        i = 2
        sh.Range("A1:B1").Value = Array("الكود", "الاسم")
        For Each e In .keys
            sh.Cells(i, "A").Resize(, 2) = Split(e, ",")
            i = i + 1
        Next e
    End With
End Sub

 

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

تم تعديل أغسطس 4, 2017 بواسطه محمود أبوالدهب

[ياسر خليل أبو البراء]

ربنا يكرمك أخي محمود

إنت هتيأس من دلوقتي ولا ايه

أقصد الكود الأول بسيط ومباشر ..يعني لو قمت بتسجيل ماكرو بالخطوات ستعرف إنه بسيط حيث يتم نسخ النطاق المطلوب لورقة العمل الثانية ثم إزالة المكرر باستخدام خاصية Remove Duplicates الموجودة في التبويب Data ثم حذف الأعمدة الغير ضرورية ثم نقل العمود إلى العمود الذي قبله للترتيب ...أمور بسيطة

لتتعلم الأكواد حاول تستخدم مفتاح F8 لتنفيذ الكود سطر بسطر .. لتتعلم وتعرف ما يحدث أول بأول ..