بدون تكرار

[نور وحيد]

ارجو من الاخوة الافاضل المساعدة فى تنفيذ المطلوب فى الملف المرفق

وللجميع جزيل الشكر و العرفان الملف المرفق اكسل 2016

بدون تكرار.rar

[Yasser Fathi Albanna]

اخى الفاضل

هل تقصد هكذا

شاهد المرفق وإضغط وشاهد النتيجة

 

فرز المكرر بإجمالى مبيعاته مرتب أبجديا.rar

[نور وحيد]

فعلا هو المطلوب ولكن الكود مشفر وكيفية تطبيقة على ملفى

تم تعديل نوفمبر 9, 2015 بواسطه نور وحيد

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

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

جرب الكود التالي عله يفي بالغرض

Sub Summary()
    Dim I As Long, J As Long, M As Long, N As Long, LR As Long, V, ZUM
    Dim C As Collection
    Set C = New Collection
    
    Application.ScreenUpdating = False
        On Error Resume Next
        For I = 3 To Rows.Count
            V = Cells(I, 1).Value
            If V = "" Then
                N = I - 1
                Exit For
            End If
            C.Add V, CStr(V)
        Next I
        On Error GoTo 0
        
        M = 3
        For I = 1 To C.Count
            Cells(M, 5) = C.Item(I)
            ZUM = 0
            For J = 3 To N
                If Cells(J, 1).Value = Cells(M, 5).Value Then
                    ZUM = ZUM + Cells(J, 2).Value
                End If
            Next J
            Cells(M, 6).Value = ZUM
            M = M + 1
        Next I
        
        LR = Range("E" & Rows.Count).End(xlUp).Row
        Range("E3:F" & LR).Sort Key1:=Range("E1:E" & LR), Order1:=xlAscending, Header:=xlNo
    Application.ScreenUpdating = True
End Sub

وإليك الملف المرفق الخاص بك

Unique Items With SUM & Sort YasserKhalil.rar

[Yasser Fathi Albanna]

الله عليك يا أ / ياسر

كود أكثر من رائع أخى الحبيب

تسلم يمينك

ومرفق أيضا المرفق الأول للحل بدون كماية VBA بعد إذنك يا أ / ياسر

 

فرز المكرر بإجمالى مبيعاته مرتب أبجديا.rar

[نور وحيد]

ما اروع الكودان وشكرا لكل من الاستاذ / 

• ياسر خليل
• ياسر فتحى

[نور وحيد]

لو امكن شرح الكودان 

[محمد الورفلي1]

2 ساعات مضت, نور وحيد said:

لو امكن شرح الكودان 

 

نعم نريد اذ امكن الشرح

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

لا استطيع الا ان اتدخل بهذا الكود

Sub sumif_order()
Range("e3:f100").Clear
LR = Cells(Rows.Count, 1).End(3).Row
Set Myrg = Range("a3:a" & LR)
For I = 3 To LR
 If Application.CountIf(Range("a3:a" & I), Range("a" & I)) = 1 Then
  Cells(k + 3, 5) = Range("a" & I)
  k = k + 1
  End If
  Next
  LRe = Cells(Rows.Count, 5).End(3).Row - 2
  Range("E3:F" & LRe).Sort Key1:=Range("E1:E" & LRe), Order1:=xlAscending, Header:=xlNo
  Range("f3:f" & LRe + 2).Formula = "=SUMIF($A$3:$A$100,E3,$B$3:$B$100)"
End Sub

 

[الـعيدروس]

السلام عليكم

الى حلول الاخوة الكافيه الوافيه بطريقه اخرى

Public Ali_1()
Dim Lr&, Rw&, Rng As Range
Application.ScreenUpdating = False
Lr = Range("A" & Rows.Count).End(xlUp).Row: Range("A3:B" & Lr).Copy [E3]
Set Rng = Range("E" & Lr + 10)
For Rw = 3 To Lr
  If Application.CountIf(Range("E3:E" & Rw), Range("E" & Rw)) > 1 Then
    Set Rng = Union(Rng, Range("E" & Rw))
 Else
    Cells(Rw, 6) = Application.SumIf(Range("E:E"), Range("E" & Rw), Columns(6))
  End If
Next Rw
Union(Rng, Rng.Offset(0, 1)).Delete Shift:=xlUp: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

 

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

أخي الحبيب سليم حاصبيا

أخي الغالي أبو نصار

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

تقبلا تحياتي

[نور وحيد]

هناك مشكلة مع كود الاستاذ/ سليم

                               الاستاذ/ العيدروس

وظهور رسالة ان الكود لا يتناسب مع سيستم 64 بيت

ويحتاج الى التحديث فما هو الحل كما انى ما زلت ارغب فى شرح الكود حتى استطيع استخدامة وتطويعة فى الملف الخاص بى بالنسبة للاستاذ/ ياسر خليل 

م/ياسر فتحى        

[الـعيدروس]

ارفق صورة للخطاء مع توضيح في اي سطر فالكود ظهر الخطاء