مختار حسين محمود

أشكرك أخى ابراهيم اذن وبدون حذف جرب اضافة السطرين فى نهاية الكود On Error GoTo 1 1: Workbooks("1").Activate

أخى و أستاذى الغالى ياسر : ليه الرقم 30 تحديدا ؟ جربت 10 و 20 و 30 و 40 والكود شغال ولا فيه حاجة مش واخد بالى منها

رااااااااااائع عندى حق أنا لما بقول إنك أستاذى ولا لأ ؟

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

جرب ترحيل البيانات الى كل الأوراق و شيل السطر ده و جرب الكود

ضع الكود التالى فى مديول جديد الكود لمسح النطاق من الخلية a4 الى آخر خلية فى العمود j فى كل الاوراق و أؤكد مرة أخرى لابد من تتطاق جميع الأورارق Option Explicit Sub delallData() Dim ws As Worksheet On Error Resume Next Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets With ws .Activate .Range(Cells(4, "A"), Cells(Rows.Count, "J")).ClearContents End With Next ws On Error GoTo 0 Sheets("data").Activate Application.ScreenUpdating = True End Sub تحياتى

حضرتك غيرت فى ورقة DATA أعمدة جديدة لذا ينبغى عليك أن تعديل فى الأوراق المرحل اليها لتتطابق تماما مع ورقة DATA تجنبا لحدوث أخطاء هذا ما لاحظته فى المرفق الاخير

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Application .ScreenUpdating = False .DisplayAlerts = False End With If Target.Column <> 3 Then Exit Sub Select Case Target.Value Case Is = 1 Target.Offset(0, -1).Resize(, 7).Copy With Sheets("c1").Range("B1000").End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths End With Case Is = 2 Target.Offset(0, -1).Resize(, 7).Copy With Sheets("c2").Range("B1000").End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths End With Case Is = 3 Target.Offset(0, -1).Resize(, 7).Copy With Sheets("c3").Range("B1000").End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths End With Case Is = 4 Target.Offset(0, -1).Resize(, 7).Copy With Sheets("c4").Range("B1000").End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths End With Case Is = 5 Target.Offset(0, -1).Resize(, 7).Copy With Sheets("c5").Range("B1000").End(xlUp).Offset(1, 0) .PasteSpecial xlPasteValues .PasteSpecial xlPasteColumnWidths End With End Select With Application .CutCopyMode = False .ScreenUpdating = True .DisplayAlerts = True End With End Sub ده عشان الطلب الاول نسخ القيم وعرض الأعمدة فقط الطلب التانى عايز تمسح العمود C وكل البيانات فى كل الأوراق مش كده ولا تقصد حاجة تانى ؟

حضرتك هتكمل بكود الأستاذ سليم و لا الكود الأخير

عذرا نسيت انك مرقم التلاميذ فى كل الاوراق جرب ده عشان الترقيم Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False If Target.Column <> 3 Then Exit Sub Select Case Target.Value Case Is = 1 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الاول").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 2 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثانى").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 3 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الثالث").Range("B1000").End(xlUp).Offset(1, 0) Case Is = 4 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الرابع").Range("B1000").End(xlUp).Offset(1, 0) Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 5 Target.Offset(0, -1).Resize(, 7).Copy Sheets("الصف الخامس").Range("B1000").End(xlUp).Offset(1, 0) End Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.DisplayAlerts = False If Target.Column <> 3 Then Exit Sub Select Case Target.Value Case Is = 1 Target.EntireRow.Copy Sheets("الصف الاول").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 2 Target.EntireRow.Copy Sheets("الصف الثانى").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 3 Target.EntireRow.Copy Sheets("الصف الثالث").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 4 Target.EntireRow.Copy Sheets("الصف الرابع").Range("A1000").End(xlUp).Offset(1, 0) Case Is = 5 Target.EntireRow.Copy Sheets("الصف الخامس").Range("A1000").End(xlUp).Offset(1, 0) End Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub بعد اذن الاستاذ سليم هذه الاضافة أخى الكريم ضع الكود التالى فى حدث الورقة بمجرد ادخال رقم الصف فى العمود c يتم الترحيل مباشرة

السلام عليكم أخى ابراهيم نعم يوجد خطأ أعتقد أنه بسبب الـ 2 يوزر فورم اجعل لكل منهما كود اغلاق تحياتى

تحياتى لأستاذنا الفاضل بن عليه نعم كلامك صحيح 100 % جرب الملف ده لم أجربه بعد التعديل معنديش 64 64 توزيع الملاحظة.rar 64 توزيع الملاحظة.rar

Sub ShowUF() Dim strPass As String Dim LCount As Integer For LCount = 1 To 3 strPass = InputBox(Prompt:="الرجاء إدخال كلمة المرور", Title:="كلمة المرور") If strPass = vbNullString Then Exit Sub ElseIf strPass <> "123" Then MsgBox "كلمة المرور غير صحيحة", vbCritical, "التأكد من كلمة المرور" Else UserForm1.Show Exit For End If Next LCount If LCount = 4 Then Exit Sub End Sub تحياتى أخى رجب بارك الله فيكم أخى محمد وجرب الكود السابق كمان

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

أخى ياسر بارك الله فيك وجزاك خيرا الى كل الأخوة بالمنتدى رجاء لابد من ارفاق ملف للعمل عليه لنتجنب البعد عن الفرضيات والتخمينات تحديث الأوفيس لديكم على الأقل 2010 للحصول على أفضل الامكانات فى الأوفيس وحتى لا تحدث لدينا مثل هذه الاشكاليات ونوفر وقتنا وجهدنا وشخصيا أعجبنى الكود الأول لأنه أبسط و أسهل وأستاذن أستاذى ياسر فى هذه الصورة الجديدة للكود : تم الاستغناء عن الدالة GetCellColorForReals و الرقم 65535 الذى يمثل اللون الأصفر والتعويض عنه بـ ColorIndex = 6 Option Explicit Sub CountCellsByColorIndex() Dim Ws As Worksheet, Cel As Range, i As Integer Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets For Each Cel In Ws.Range("I7:I" & Ws.Cells(Rows.Count, "I").End(xlUp).Row) If Cel.DisplayFormat.Interior.ColorIndex = 6 Then i = i + 1 ' ColorIndex =6 هو اللون الأصفر Next Cel Next Ws If i = 0 Then MsgBox "لا يوجد خلايا ملونة ", 64 Else MsgBox "عدد الخلايا الملونة يساوي " & i End If Application.ScreenUpdating = True End Sub تحياتى

أستاذى الفاضل رجب كود رائع بارك الله فيك ملحوظة صغيرة و ليس تعديلا : كما قال أخونا وأستاذنا ياسر خليل لا تنسى الاعلان عن كل المتغيرات فى أكوادك اجعل السطر التالى : Option Explicit على رأس أكوادك فهو لن يتركك الا اذا أعلنت عن كل المتغيرات و كفيل بتذكيرك بذلك تحياتى

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

أخى و أستاذى رجب بارك الله فيك و جزاك خيرا أخى و أستاذى ياسر خليل بارك الله فيك و جزاك خيرا

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

المشرف الجميل الغلاباااااااوى ملف جميل تسلم ايدك بس ليه الهديه تفك المحمى ..... و هيه محميه !!! تحياتى و تقديرى

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

الله الله على الكلمات الجميله التى تثلج القلب أخى أحمد أحبك الذى أحببتنا فيه وتقبل دعاءك و جزاك عنا خيرا و زادك من علمه و فضله كل التحية و التقدير لشخصكم النبيل أخيك مختار

أخى و أستاذى ياسر جزاكم الله خيرا على دعمك وتشجيعك الدائم واعلم تمام العلم أن هذا ما هو إلا ثمرة بذرة غرستها أنت فىّ ألا وهى عشق الاكسل تقبل منى وافر التحية و التقدير أخى نايف مشكور على مرورك وعلى حرصك على التطبيق بالنسبة للرسالة الظاهرة لك : يظهر هذا النوع من الرسائل اذا كان فى الملف كودين يحملان نفس الاسم تأكد من أن الملف ليس فيه كود فى حدث الملف يبدأ بهذا الاسم :Private Sub Workbook_Open لان هذا الاسم يساوى Auto_Open حاولت أمس أن أرد عليك لكن النت فصل امبارح أثناء الرد لكن و رانا مشرف و مراقب نشيط هو حبيبنا فى الله ياسر خليل قام بالواجب وزيادة أخى احمد الفلاحجى مشكور على مرورك وعلى حرصك على زيادة المعرفة

شكرا أحمد الفلاحجى شكرا أخى محمد الزريعى جزاكم الله خيرا