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

أخي الكريم عامر ياسر إثراءً للموضوع .. كنت قد قدمت من فترة موضوع بنفس الفكرة على الرابط التالي الرابط من هنا وقمت بعمل بعض التعديلات ليتناسب الكود مع ملفك .. إليك الكود التالي ويوضع في موديول عادي Sub SplitList() 'تعريف المتغيرات Dim shSource As Worksheet, shTarget As Worksheet Dim rList As Range, rListA As Range, rListB As Range Dim hCount As Long, tCount As Long Const colNum As Integer = 5 'عدد أعمدة النطاق المراد عمل إنشطار له 'تعيين ورقة العمل المصدر التي تحتوي القائمة الرئيسية وورقة العمل الهدف Set shSource = Sheets("البيانات") Set shTarget = Sheets("الناجحون") 'تعيين النطاق الذي يحتوي على القائمة المراد شطرها Set rList = shSource.Range("A5:A" & shSource.Cells(Rows.Count, "B").End(xlUp).Row) 'تعيين بداية النطاق للشطر الأول من القائمة Set rListA = shTarget.Range("A5") 'تعيين بداية النطاق للشطر الثاني من القائمة Set rListB = rListA.Offset(, colNum) 'تعيين قيمة المتغير ليساوي عدد خلايا النطاق المصدر tCount = rList.Cells.Count 'تعيين قيمة للمتغير ليساوي تقريب قيمة قسمة المتغير السابق ÷ 2 hCount = Round(tCount / 2, 0) 'مسح النطاق الذي ستظهر فيه النتائج للشطر الأول والشطر الثاني shTarget.Range("A4:J10000").ClearContents 'وضع نتائج الشطر الأول rListA.Resize(hCount, colNum).Value = Range(rList(1).Address(External:=True) & ":" & rList(hCount).Address(External:=True)).Resize(hCount, colNum).Value 'وضع نتائج الشطر الثاني rListB.Resize(tCount - hCount, colNum).Value = Range(rList(hCount + 1).Address(External:=True) & ":" & rList(tCount).Address(External:=True)).Resize(hCount, colNum).Value MsgBox "Done ..." & vbNewLine & "Best Regards" & Chr(10) & "YasserKhalil", 64 End Sub تقبل تحياتي

وسيكتمل المنتدى إن شاء الله بتواجدك بيننا فأنت قمة وهامة في هذا المجال تقبل وافر تقديري واحترامي

جرب الفلترة ثم إعطاء أمر الطباعة يمكن تسجيل ماكرو بهذا الأمر .. هذا على حسب رأيي بشكل سريع للموضوع

أستاذي الكبير ومعلمي الفاضل أبو تامر بارك الله فيك وجزيت خير الجزاء على هذه الدرر التي حرمنا منها كثيراً ولكن مشئية الله أرادت لنا الخير بعد طول انتظار جربت الملف المرفق واطلعت على الأكواد ووجدت أن اسم المصنف الحالي يدرج في قائمة الملفات ولتفادي المشكلة (حيث يتسبب في تهنيج برنامج الإكسيل) قمت بعمل إضافة بسيطة جداً لعدم إدراج اسم المصنف الحالي .. وذلك بعد سطر الحلقة التكرارية في الإجراء الفرعي المسمى Sub ListMy_Files(Path, Sub_Folder As Boolean) حيث قمت بإضافة السطر التالي If My_File.Name <> ThisWorkbook.Name Then ........... End If وذلك ما بين سطري الحلقة التكرارية For Each My_File In My_Source.Files ......... Next My_File وفي الإجراء المسئول عن عملية البحث عن الملف قمت بإضافة سطر في حالة لم يتم اختيار ملف من الخلية A2 File_Name = Range("A2") If IsEmpty(File_Name) Then MsgBox "No File To Search!", vbExclamation: Exit Sub تقبل وافر تقديري واحترامي

أخي الكريم جرب الكود التالي Sub UniqueListFromMultipleSheets() Dim X, Y(), I&, J&, K&, WS As Worksheet ReDim Y(1 To Rows.Count, 1 To 1) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each WS In ThisWorkbook.Worksheets(Array("Class1", "Class2", "Class3", "Class4", "Class5")) X = WS.Range("B3:B" & WS.Cells(Rows.Count, "B").End(xlUp).Row).Value For I = 1 To UBound(X) If Len(X(I, 1)) Then If Not .Exists(X(I, 1)) Then J = J + 1 .Item(X(I, 1)) = J Y(J, 1) = X(I, 1) End If End If Next I Next WS End With With Sheets("Report") .Range("C3").Resize(J, 1).Value = Y() End With End Sub ستظهر القائمة في الخلية C3 في ورقة العمل Report >> أو إذا أردت في الخلية B3 قم بإزالة الجدول وجعل النطاق نطاق عادي ثم غير المرجع في الكود تقبل تحياتي

هل قمت بتنفيذ الخطوات بشكل صحيح؟ ربما التبس عليك الأمر في الخيار في الصورة الأخيرة حيث يتم الاختيار من القائمة المنسدلة الأولى المسماة Comments وليس القائمة المنسدلة المسماة Cell errors As جرب مرة أخرى لأنها تظهر لدي في الورقة المطبوعة

وعليكم السلام أخي الكريم يرجى تغيير اسم الظهور للغة العربية ومراعاة الدقة في عناوين الموضوعات جرب الكود التالي في حدث ورقة العمل Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 2 And Target.Row > 6 Then Target = Mid(Target.Offset(-1), 1, 6) SendKeys "{F2}" End If End Sub تقبل تحياتي

أخي الكريم ارفق ملفك لتتضح صورة المشكلة بشكل أفضل

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

وعليكم السلام أخي الكريم وائل في الخلية التي فيها التعليق اعمل كليك يمين ثم اختر الأمر Show/Hide Comments ثم اتبع ما في الصور لتقوم بالمطلوب

الموضوع مكرر على ما أعتقد .. يرجى وضع رابط الموضوع الآخر لحذف أحدهما

الحمد لله أنك توصلت للحل .. يرجى وضع الأكواد بين أقواس الكود ليظهر بشكل منضبط تقبل تحياتي

أخي الكريم عبد الرؤوف يرجى توضيح طلبك بشيء من التفصيل حتى تجد الاستجابة من قبل إخوانك بالمنتدى

الحمد لله أن تم المطلوب على خير وجزيتم خيراً على دعائكم الطيب

يوجد كودين في حدث فتح المصنف بنفس الاسم قم بدمج الأكواد ..أو ارفع الملف ليستطيع الأخوة تقديم المساعدة إن شاء الله

جرب الكود التالي في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then If Target.Value <> 2 Then Application.EnableEvents = False Target.ClearContents Application.EnableEvents = True End If End If End Sub

جرب الكود التالي في حدث المصنف Private Sub Workbook_Open() Dim Sh As Worksheet For Each Sh In ThisWorkbook.Worksheets Sh.Range("IV1").Value = "True" Next Sh End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim Sh As Worksheet Dim Sn As Worksheet Dim Rng As Range Application.ScreenUpdating = False Application.Calculation = xlManual For Each Sn In ThisWorkbook.Worksheets If Sn.ProtectContents = True Then Sn.Unprotect Password:="123": Sn.Cells(1, "IV") = "True": Sn.Protect Password:="123" Next Sn For Each Sh In ThisWorkbook.Worksheets If Sh.ProtectContents = True Then Sh.Unprotect Password:="123": Sh.Cells.Locked = False If Not Sh.Cells.HasFormula Then Sh.Cells.Locked = False Else Sh.Cells.FormulaHidden = True For Each Rng In Sh.UsedRange On Error Resume Next If Rng.Value > Empty Or Rng.HasFormula Then Rng.Locked = True Next Rng If Sh.Cells(1, "IV") = "True" Then Sh.Protect Password:="123" Next Sh Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub احفظ المصنف ثم أغلقه ثم قم بإعادة فتح وتجربة الحماية

نعم يمكن تطبيق الماكرو على نطاق محدد بفرض أن النطاق له متغير باسم Rng كما هو موضح بالصورة ضع السطر بالشكل التالي Set Rng = Range("B4:B200") وارفق ملفك للإطلاع عليه لمحاولة مساعدتك في الخطأ الذي يظهر لديك تقبل تحياتي

أخي الكريم مشعل إليك الفيديو التالي فيه توضيح لحل المشكلة .. ويرجى الإطلاع على موضوع "بداية الطريق لإنقاذ الغريق" لمعرفة أساسيات التعامل مع محرر الأكواد رابط الفيديو رابط الموضوع http://yasserkhalilexcellover.blogspot.com.eg/2016/04/blog-post.html

أخي الكريم ارفق ملف للعمل عليه وليسهل توضيح مطلوبك

أخي الكريم هلا أوضحت المطلوب بشيء من التفصيل .. هل تريد إدراج الفلاش لورقة العمل والكتابة عليها ؟؟؟!! وما هي شروط تغير البيانات أقصد الخلية المرتبطة بتغير البيانات؟

أين الملف المرفق أخي الفاضل؟ يرجى وضع عناوين مناسبة ومعبرة عن الموضوعات تقبل تحياتي

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

كلمة Delete تقوم بالحذف وليس مسح المحتويات ، أما ClearContents هي التي تقوم بمسح المحتويات وليس الحذف

أخي الكريم حسين جرب الكود التالي عله يكون المطلوب إن شاء الله Sub Test() Dim Cel As Range If Not Intersect(ActiveCell, Range("A2:A100")) Is Nothing Then For Each Cel In Selection If IsEmpty(Cel) Then Cel.Value = Cel.Offset(, 1).Value Cel.Offset(, 1).ClearContents Cel.Offset(, 2).Value = Date End If Next Cel End If End Sub تقبل تحياتي