مشعل سلطان قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 السلام عليكم ورحمة الله وبركاته الشرح بالمرفقات Book1.rar واجهة الكثير في اضافة الموضوع ونعتذر عن الخطا الغير مقصود في تعدد الموضوع نرجو الابقاء على موضوع واحد وحذف الباقي رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 جرب هذا الملف Book1 _macro.zip 2 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 Sub UniqueSortSpecial() Dim A As Variant, X As Variant, I As Long, J, N& Application.ScreenUpdating = False With Sheet1.Range("A2").CurrentRegion A = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = 1 To UBound(A, 1) For J = 1 To UBound(A, 2) If A(I, J) <> vbNullString Then If Not .Exists(A(I, J)) Then .Item(A(I, J)) = 1 Else .Item(A(I, J)) = .Item(A(I, J)) + 1 End If End If Next Next X = .Items: J = .Keys: N = .Count End With .Range("F1").Resize(N, 2) = Application.Transpose(Array(J, X)) With .Range("F2").CurrentRegion .Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Key2:=.Cells(1, 1), Order2:=xlDescending, Header:=xlNo End With End With Application.ScreenUpdating = True End Sub أخي الحبيب الغالي سليم الكود لم يعطي نتائج صحيحة راجع الكود مرة أخرى .. ولي رجاء أن تقوم بتعريف المتغيرات وتضع الأكواد في موديول عادي وليس في موديول ورقة العمل ...أعتقد أن هذا أفضل أخي الكريم مشعل سلطان إليك الكود التالي عله يفي بالغرض Count Unique & Sort By Most Occurrences YasserKhalil.rar 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 (معدل) 31 دقائق مضت, ياسر خليل أبو البراء said: Sub UniqueSortSpecial() Dim A As Variant, X As Variant, I As Long, J, N& Application.ScreenUpdating = False With Sheet1.Range("A2").CurrentRegion A = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = 1 To UBound(A, 1) For J = 1 To UBound(A, 2) If A(I, J) <> vbNullString Then If Not .Exists(A(I, J)) Then .Item(A(I, J)) = 1 Else .Item(A(I, J)) = .Item(A(I, J)) + 1 End If End If Next Next X = .Items: J = .Keys: N = .Count End With .Range("F1").Resize(N, 2) = Application.Transpose(Array(J, X)) With .Range("F2").CurrentRegion .Sort Key1:=.Cells(1, 2), Order1:=xlDescending, Key2:=.Cells(1, 1), Order2:=xlDescending, Header:=xlNo End With End With Application.ScreenUpdating = True End Sub أخي الحبيب الغالي سليم الكود لم يعطي نتائج صحيحة راجع الكود مرة أخرى .. ولي رجاء أن تقوم بتعريف المتغيرات وتضع الأكواد في موديول عادي وليس في موديول ورقة العمل ...أعتقد أن هذا أفضل أخي الكريم مشعل سلطان إليك الكود التالي عله يفي بالغرض Count Unique & Sort By Most Occurrences YasserKhalil.rar اخي ياسر ورد خطأ بسيط في الكود و تمت المعالجة Sub Tekrar() Dim lr, Mymax, Myin, i As Integer Dim Myrg As Range, m As String lr = Cells(Rows.Count, 1).End(3).Row Columns("F:g").ClearContents Set Myrg = Range("A1:d" & lr) Mymax = Application.Max(Myrg): Mymin = Application.Min(Myrg) For i = 0 To Mymax - 1 If Mymin + i > Mymax Then Exit For Range("f" & i + 2) = Mymin + i Next Range("f1") = "الأعداد": Range("g1") = "التكرار" lr1 = Cells(Rows.Count, "f").End(3).Row m = "countif( $A$1:$D$" & lr & ",F2)" Range("g2:g" & lr1).Formula = "=" & m Range("g2:g" & lr1).Value = Range("g2:g" & lr1).Value Range("f2:g" & lr1).Sort key1:=Range("g2"), order1:=xlDescending End Sub تم تعديل نوفمبر 12, 2015 بواسطه سليم حاصبيا 1 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 ما زال الكود الخاص بك يعطي نتائج غير صحيحة ..طبق الكود الذي أرفقته وقارن النتائج ... 1 رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 اخي ياسر لم ار اي خطأ بعد التعديل اليك الملف وفيه التنسيق الشرطي لايضاح العدد المطلوب من خلال التغيير في الخلية H2 Book1 _macro 2.zip 1 رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 (معدل) السلام عليكم لم افهم طلب الاخ مشعل الا من ردودكم بارك الله فيكم اخي سليم واخي ياسر كنت اضن التنازلي بالقيمة وليس بعدد التكرار تقبلو تحياتي هذا ماعملت عليه حسب القيمة Sub Ali_A() Dim Rn As Range Dim Ar, S_A, y, I, J, It On Error Resume Next Set Rn = Range("A2:D21") Set Ap = Application.WorksheetFunction: ii = 2 With CreateObject("scripting.dictionary") For Each It In Rn y = .Item(It.Value) Next Ar = Split(Join(.Keys, ","), ",") For I = LBound(Ar) To UBound(Ar) For J = I + 1 To UBound(Ar) If Ar(I) < Ar(J) Then S_A = Ar(J): Ar(J) = Ar(I): Ar(I) = S_A Next J If Ap.CountIf(Rn, Ar(I)) > 0 Then _ Cells(ii, "G") = " تكرر العدد " & Ap.CountIf(Rn, Ar(I)) & " مرات ": Cells(ii, "F") = Ar(I): ii = ii + 1 Next End With End Sub تم تعديل نوفمبر 12, 2015 بواسطه الـعيدروس 2 رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر نوفمبر 12, 2015 مشاركة قام بنشر نوفمبر 12, 2015 أخي الكريم سليم انظر لآخر رقمين في النتائج ليسا من ضمن الأرقام والمقابل لها صفر .. كما أن الأرقام ليست مرتبة في العمود G من المفترض أن الرقم 32 أكبر من 30 فله الأولوية في الترتيب .. أخي الحبيب أبو نصار نورت الموضوع وتشرفنا بتواجدك بمجرد ردك 1 رابط هذا التعليق شارك More sharing options...
مشعل سلطان قام بنشر نوفمبر 13, 2015 الكاتب مشاركة قام بنشر نوفمبر 13, 2015 السلام عليكم ورحمة الله وبركاته الاستاذ سليم الاستاذ ياسر الاستاذ العيدروس نفع الله بعلمكم وجزاكم الله خيرا في الدنيا و الاخره في مواضيعي السابقة كان الحل على شكل دالة اقوم بنسخها وانقلها للملف المطلوب اليوم تغيرت علي الطريقة فياليت تساعدني سأبدي اعجابي للجميع هل الكود يختلف عن المعادلة وكيف يمكن نسخ الكود لوضعه في ملف اكسل اخر ياليت المساعدة رابط هذا التعليق شارك More sharing options...
ياسر خليل أبو البراء قام بنشر نوفمبر 13, 2015 مشاركة قام بنشر نوفمبر 13, 2015 أخي الكريم يمكنك الإطلاع على هذا الموضوع لمعرفة كيفية التعامل مع محرر الأكواد كبداية بداية الطريق لإنقاذ الغريق كما يمكنك مشاهدة الفيديو التالي https://www.youtube.com/watch?v=9X7hlw4G6r8 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.