سليم حاصبيا

جرب هذا الكود Option Explicit Dim x%, y% Dim Dic As Object Dim Sh As Worksheet Dim My_rg As Range Sub All_in_One() Application.ScreenUpdating = False Set Sh = Sheets("Sheet1") Set Dic = CreateObject("Scripting.Dictionary") With Sh .Range("H1").CurrentRegion.Clear For y = 1 To .Range("A1").CurrentRegion.Columns.Count For x = 2 To _ .Range("A1").CurrentRegion.Rows.Count If .Cells(x, y) <> "" Then Dic(.Cells(x, y).Value) = "" End If Next x Next y If Dic.Count = 0 Then GoTo Bay_Bay .Range("H1") = "ALL" .Range("H2").Resize(Dic.Count) = _ Application.Transpose(Dic.keys) If .Range("H1").CurrentRegion.Rows.Count > 1 Then With .Range("H1").CurrentRegion .Borders.LineStyle = 1 .Font.Bold = True: .Font.Size = 14 .InsertIndent 1 .Interior.ColorIndex = 35 .Cells(1, 1).Interior.ColorIndex = 6 End With End If End With Bay_Bay: Set Sh = Nothing Set Dic = Nothing Application.ScreenUpdating = True End Sub الكلف مرفق abou_has_All_in_one.xlsm

الملف جاهز mostafa _new.xlsm

تم معالجة الامر كما تريد الصفحة Salim من هذا الملف mostafa_Auto.xlsm

اتبع هذه الخطوات حسب الصورة

أولاً ارفع ملف نموذج عما تريد (3 صفحات لا اكثر واحدة للطلاب و 2 للاساتذة) لأن الماكرو الذي يعمل على صفحة واحدة يمكنه العمل على الالوف منها ثانياً تخفيف حجم الملف (أكثر من 3 ميغا) بدون هذه الزركشة من الألوان التي تبهر البصر و مجرد النطر الى الصفحات يجعل من يريد المساعدة يغير رأيه

الأكواد جاهزة للعمل (لا تحذف الصقوف بل تخفيها - لا تظهر بالطباعة - لأنه ربما احتجت اليها لا حقاً) لكن اذا كنت لا تريد عرض الطباعة استبدال .PrintPreview بــ .PrintOut

ممكن تجربة هذا الملف الكود Option Explicit Sub My_Print_Area() Dim AdrE1, AdrG1 Dim AdrE2, AdrG2 With Sheets("ورقة1") .Rows.Hidden = False AdrE1 = .Range("E1"): AdrG1 = .Range("G1") AdrE2 = .Range("E2"): AdrG2 = .Range("G2") .Rows(AdrE2 & ":" & AdrG2).Hidden = True .PageSetup.PrintArea = _ .Range("A" & AdrE1 & ":B" & AdrG1).Address .PrintPreview End With End Sub '+++++++++++++++++++++++++++++++++++ Sub Show_all() With Sheets("ورقة1") .Rows.Hidden = False .PageSetup.PrintArea = _ .Range("a1").CurrentRegion.Address End With End Sub الملف مرفق Man3em.xlsm

تم معالجة الأمر Labels_1.xlsm

الخلايا المدمجة تعيق عمل اي ماكرو أو اي معادلة (الابتعاد عنها قدر المستطاع) لا افهم ما الحاجة الى دمج عاودين A و B في حين يمكننا توسيع العامود A قدر ما نريد جرب هذا الملف Labels.xlsm

هذه المعادلة في R3 واسحب نزولاً =IF($Q3="","", SUMPRODUCT(($J$3:$J$100=$Q3)*($K$3:$K$100))+ SUMPRODUCT(($J$3:$J$100=$Q3)*($L$3:$L$100))+ SUMPRODUCT(($M$3:$M$100=$Q3)*($N$3:$N$100))+ SUMPRODUCT(($M$3:$M$100=$Q3)*($O$3:$O$100))) واذا لم تعمل معط استبدل الفاصلة بفاصلة منقوطة لتبدو هكذا =IF($Q3="";"; SUMPRODUCT(($J$3:$J$100=$Q3)*($K$3:$K$100))+ SUMPRODUCT(($J$3:$J$100=$Q3)*($L$3:$L$100))+ SUMPRODUCT(($M$3:$M$100=$Q3)*($N$3:$N$100))+ SUMPRODUCT(($M$3:$M$100=$Q3)*($O$3:$O$100))) File included mostafa.xlsx

جرب هذا تالملف Scorp.xlsm

ممكن هذه المعادلة (تتجاهل النصوص) =MAX(A1:B1)

جرب اضغط على الزر F9 اذا مشي الحال اقول لك ما العمل

XFD هو اخر عامود في في صفجة الاكسل و هل تريد اكثر من 16384 رقم متسلسل

حرب هذا الملف Columns_list.xlsx

بعد اذنك باش مهندس الاكسل هذه المعادلة ربما تضيف شيئاً ما =A3&" "&CHAR(177)&" "&B3

قمت بتبديلها في مكان واحد فقط و يجب تيديلها اينما وجدت تم تشغيل اليوزر Book_Mhmd .xlsm

هذه الصفحة (الصورة) لا وجدود لها

هناك طريقة اخرى ربما تكون الحل 1- ضعي اسماء الشيتات التي تريدينها في عامود معين مثلا ( Z1- Z100) في الشيت "TAkrir" 2- الخطأ باسماء الشيتات المطلوبة (مسافات ناقصة أو زائدة همزة الألف نفاط الياء الخ....) غير مقبول لأنه يعطي نتيحة حاطئة من الافضل استعمال نسخ ولصق 3- القوائم المنسدلة تأخذ بياناتها من هذا النطاق (لبس بالضرورة كاملاً فقط لغاية اخر خلية ربما تكون Z50 مثلاً) 4 - استبدال هذا الجزء من الكود كما في الصورة (اكثر من مرة موجود هذا الجزء) 5- الانتباه الى " _ " Under Score و قبلها مسافة واحدة فقط في المربع الأزرق بعد كلمة ,Name.

لا ينفع يجب ان يكون بين اسماء الشيتات الي يجب ان يتعاطى معها الماكرو شيء مشترك (MyData1 / Mydata2/....) مثلاً - لا أنصح بتسمية الشيتات باللغة العربية

ماهي اسماء الشيتات المطلوبة؟؟؟ هاتي 4 أو 5 اسماء فقط

كل الشيتات التي يجب ان يتفحصها الماكرو يحب ان بيدأ اسمها بـ sh يليه رقم من 1 الى ما تريدين من أرقام مثلاً ٍsh100 /....... sh3 / sh2/ sh1 لأن الكود يتعرف على الشيت من خلال اسمها اذا اردت يمكن تغيير اسماء الشيتات الى 1 datareporrt 2/datareporrt الح.... و لكن بشرط تغيير هذا الجزء في الكود كما في الصورة (اينما تجدينه) اقصد في اكثر من مكان s

يمنكك تجربة هذا الملف (صفحة Salim) Option Explicit Sub All_in_One() Dim S As Worksheet Dim Rg_A As Range, Rg_D As Range Dim i%, m%, La%, LD% Dim Obj_Num As Object, Obj_Text As Object Set S = Sheets("Salim") S.Range("I2").Resize(1000).Clear La = S.Cells(Rows.Count, 1).End(3).Row LD = S.Cells(Rows.Count, 4).End(3).Row Set Obj_Num = CreateObject("System.collections.Arraylist") Set Obj_Text = CreateObject("System.collections.Arraylist") For i = 2 To La If S.Cells(i, 1) <> vbNullString Then If IsNumeric(S.Cells(i, 1)) Then Obj_Num.Add S.Cells(i, 1).Value Else Obj_Text.Add S.Cells(i, 1).Value End If End If Next '+++++++++++++++++++++++++++++ For i = 2 To LD If S.Cells(i, 4) <> vbNullString Then If IsNumeric(S.Cells(i, 4)) Then Obj_Num.Add S.Cells(i, 4).Value Else Obj_Text.Add S.Cells(i, 4).Value End If End If Next If Obj_Num.Count Then Obj_Num.Sort End If If Obj_Text.Count Then Obj_Text.Sort End If m = 2 If Obj_Num.Count Then S.Cells(m, "i").Resize(Obj_Num.Count) = _ Application.Transpose(Obj_Num.toarray) S.Range("I2").Resize(Obj_Num.Count) _ .Interior.ColorIndex = 35 m = m + Obj_Num.Count - 1 End If If Obj_Text.Count Then S.Cells(m, "i").Resize(Obj_Text.Count) = _ Application.Transpose(Obj_Text.toarray) S.Cells(m, "i").Resize(Obj_Text.Count) _ .Interior.ColorIndex = 40 m = m + Obj_Text.Count - 1 End If With S.Range("i2").Resize(m - 1) .Borders.LineStyle = 1 .Font.Size = 14: .Font.Bold = True .InsertIndent 1 End With End Sub الملف مرفق (الصفحة Salim) ABOU_Yahya Two_in_One.xlsm

لست انا من وضع الكود لذلك لا اعرف كيفية التعامل معه

في هذه الحالة الكود افضل ما يمكن