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

أخى الكريم angelloay نسيت أرحب بك فى المنتدى فأهلا وسهلا بك ويا حبذا لو تغير اسم الظهور الى العربية لسهولة التواصل للعلم أن جمع الخلايا ذات الألوان الناجمة عن التنسيق الشرطى يشكل صعوبة على الأقل بالنسبة لى أنا شخصيا لذلك قمت بالغاء كل التنسيقات الشرطية ووضعت لك كودا فى حدث الشيت مشتريات واستخدمت دالة udf لحساب مجموع الخلايا ذات اللون الواحد فى المرفق التالى عسى يحوز اعجابك Summing cells based on Color.rar

مثال : ضع الكود التالى فى حدث الشيت Private Sub Worksheet_Change(ByVal Target As Range) If Not Range("A1").Find("اخضر") Is Nothing Then Range("A1").Offset(0, 1).Interior.ColorIndex = 4 Else Range("A1").Offset(0, 1).Interior.Pattern = xlNone End If End Sub اكتب كلمة اخضر فى A1 ستجد أن الخلية B1 صارت خضراء ثم اخذف الكلمة ستجد الخلية استعادت لونها العادى والا أرفق ملفا ضع فيه تصورك والنتائج المرجوة تحياتى

السلام عليكم ورحمة الله تعالى وبركاته مقدمة : لكى ننتقل من الخلية A1 مثلا الى آخر خلية بها بيانات فى نفس الصف الاول يكون بالطريقة الاتية : Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column).Select لكى ننتقل من الخلية A1 مثلا الى آخر خلية بها بيانات فى نفس العمود الاول يكون بالطريقة الاتية : Range("A" & Cells.Rows.Count).End(xlUp).Select ماذا لو كنا لا ندرى فى أى خلية نحن ...... اذن الانتقال سيكون من الخلية النشطة الى آخر خلية بها بيانات فى صفها أو عمود ها كيف نستخدم الخلية النشطة فى الوصول الى آخر خلية بها بيانات فى صفها أو عمود ها ؟ قبل الاجابة على السؤال نحاول نفهم الآتى : طبعا احنا عارفين أن اى خلية ليها صف وليها عمود ماشى لو عندنا الخلية النشطة هى $A$1 كيف نحصل على رقم الصف وكيف نحصل على اسم العمود من التركيبة $A$1 علامتى الدولار والحرف والرقم سنعتمد على الدالة MID وبنيتها كالتالى ( النص الذى سنستخرج منه + نقطة البداية + عدد الاحرف المطلوبة ) ( MID( text ; start position ; Number of characters وظيفتها استخلاص جزء من نص بداية من نقطة محددة فيه وعدد محدد من الحروف ضع النص $A$1 فى خلية ولتكن A1 نحصل على رقم الصف بالمعادلة =MID(A1; 4; 1048576) نحصل على اسم العمود بالمعادلة =MID(A1; 2; 1) المعادلة دى ستعطيك اسم العمود وهو A كيف نستفيد من ذلك فى الانتقال من الخلية النشطة الى آخر خلية بها بيانات فى صف أو عمود الخلية النشطة ؟ بسيطة : بص على سطر الكود الأول فيه الرقم 1 ومكرر مرتين ويمثل رقم الصف تعالى نشيل رقم الصف ونضع ما يساويه بالمعادلات Cells(Mid(ActiveCell.Address, 4, 1048576), Cells(Mid(ActiveCell.Address, 4, 1048576), Columns.Count).End(xlToLeft).Column).Select هذا السطر يستخدم فى الانتقال من الخلية النشطة الى آخر خلية بها بيانات فى نفس صف الخلية النشطة بص كمان على سطر الكود الثانى ستجد فيه "A" اسم العمود شيل اسم العمود وضع المعادلة التى هتطلع لنا اسم العمود Range(Mid(ActiveCell.Address, 2, 1) & Cells.Rows.Count).End(xlUp).Select هذا السطر يستخدم فى الانتقال من الخلية النشطة الى آخر خلية بها بيانات فى نفس عمود الخلية النشطة ناس هتقول ايه فائدة ده كله ؟ هقوله جرب المرفق التالى وأنت تعرف ممكن يعملوا ايه ! ملحوظة 1 : ده مش معناه أن السطرين دول وبس ممكن يعملوا ما فى المرفق ملحوظة 2 : فى المرفق تم اضافة الخاصية Offset على السطرين . find last entry in Rows and columns by mokhtar .rar والسلام عليكم ورحمة الله تعالى وبركاته

أخى سليم ويكتب أيضا هكذا ليشمل كل المعادلات النصية والرقمية Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeFormulas).Interior.ColorIndex = 38 لكن لا يصلح فى طلب الأخ نايف جرب الكود مع معادلة هتلاقى الكود أعطى المعادلة اللون 38 ثم شيل المعادلة ستجد اللون الجديد 38 كما هو و جرب ادخال نص مكان معادلة ستجد اللون كما هو أيضا الأخ نايف جرب الكود التالى Private Sub Worksheet_Change(ByVal Target As Range) Dim C As Range Dim rng As Range ' تحديد نطاق الفحص Set rng = Range("B2", Range("B" & Rows.Count).End(xlUp)) ' تحديد الخلايا التى تتضمن معادلات For Each C In rng If C.HasFormula And C.Offset(, -1) <> "" Then C.Interior.ColorIndex = 38 Else C.Interior.Pattern = xlNone End If Next C End Sub

بارك الله فيك أخى ياسر وجازاكم خيرا على ما تقدمه لنا الأخ سعد الفقير لتطبيق الكود على النطاق K2:K50 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Application.Intersect(Target, Range("$K$2:K50")) Is Nothing Then ActiveWindow.Zoom = 150 Else ActiveWindow.Zoom = 100 End If End Sub

الأستاذ الفاضل سليم بارك الله فيكم وبعد اذن حضرتك بالمشاركة أستاذ نايف ضع الكود التالى فى الحدث Worksheet_Change مش فى selectionchange كالتالى Private Sub Worksheet_Change(ByVal Target As Range) Dim C As Range Dim rng As Range ' تحديد نطاق الفحص Set rng = Range("B2", Range("B" & Rows.Count).End(xlUp)) ' تحديد الخلايا التى تتضمن معادلات For Each C In rng If C.HasFormula Then C.Interior.ColorIndex = 38 Else C.Interior.Pattern = xlNone End If Next C End Sub وغير فى النطاق المحدد من معادلات الى نص أو العكس تلوين خلايا 2.rar

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

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

أستاذ حسين يرجى تغيير اسم الظهور الى اللغة العربية لسهولة التواصل ثانيا هذا شرح للكود ببعض التعليقات عليه الكود الاول يوضع فى حدث المصنف Private Sub Workbook_Open() Application.ScreenUpdating = False ' منع تحديث الشاشة Sheets("سري").Visible = 2 ' اخفاء الورقة سرى عند فتح الملف وعدم القدرة على اظهاره يدويا Sheets("بيانات").Activate ' تنشيط ورقة العمل بيانات فى بداية فتح الملف Application.ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة End Sub الكود الثانى يوضع فى حدث ورقة بيانات Private Sub Worksheet_Activate() ' فى حالة تنشيط ورقة بيانات فانه يتم Application.ScreenUpdating = False Sheets("سري").Visible = 2 ' اخفاء الورقة سرى Application.ScreenUpdating = True End Sub Sub showsheet() Dim pwd As String ' اعتبارالمتغير من نوع نص pwd = "123" ' كلمة السر يمكنك تعديلها Application.ScreenUpdating = False Application.DisplayAlerts = False If Application.InputBox("What is the password to view this sheet?", "Access Password", "***") <> pwd Then ' اذا كانت كلمة السر المدخلة غير 123 فان MsgBox "sorry Wrong password" ' ظهور رسالة للمستخدم بأنها كلمة السر خاطئة Sheets("بيانات").Activate ' تنشيط ورقة العمل بيانات Else ' اذا كانت كلمة السر صحيحة فان With Sheets("سري") .Visible = True ' اتاحة الشيت للمستخدم .Activate ' تنشيط الشيت End With End If Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub تحياتى

أهلا وسهلا بك أستاذ حسين بين اخوانك تفضل المرفق عله يفى بالغرض كلمة السر 123 واحد سري 2.rar

السلام عليكم ورحمة الله أخى الكريم أخى الكريم خالد الرشيدي *** ياسر العربي مبارك الترقية

بارك الله فيك أخى الكريم ياسر العربى انظر أحد برامجى " برنامج تعليم الرياضيات بالاكسل لرياض الأطفال والمدارس الابتدائية " على الرابط http://www.officena.net/ib/index.php?showtopic=58297 و " تعليم اللغة الانجليزية بالاكسل لرياض الأطفال والمدارس الابتدائية " على الرابط http://www.officena.net/ib/index.php?showtopic=59850#entry383919 قد تجد فيهما ما تريد تحياتى ومنتظرين التجديد

أستاذى الكبير ياسر للعلم أنه يتم انشاء النطاقات المحمية بباسورد + الباسورد نفسه أثناء عدم حماية الشيت ثم تتم حماية الشيت وأعتقد أنك عملت تغيير الباسورد فى الكود والشيتات محمية لذلك لم يفلح الباسورد الجديد فى العمل لتغيير الباسورد : غيره فى الكود + فك حماية الشيت + Allow user to Edit Ranges + حذف للنطاق + أعد حماية الشيت + حفظ + غلق الملف واعادة فتحه أخى الكريم خليفة نقل الكود الى ملف آخر يستلزمه حماية الشيتات يعنى ضع الكود فى الملف الجديد واعمل حماية للشيتات قبل الحفظ ثم أغلق الملف وأعد فتحه هتلاقيه شغال .

أخى أنس مشكور على الأكواد الجميلة دى واثراء للموضوع ده كود تغيير المستخدم SwitchUser Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Sub SwitchUser() Dim su su = ExitWindowsEx(EWX_REBOOT, 0) End Sub تحياتى

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

برافو أهو كده يبقى التاتش المصرى

أخى الغالى ياسر فتحى بارك الله فيك و مشكور على مرورك والله فى أيام كثر فيها (اخطف واجري قبل ما صاحب الموضوع يدري ... )

السلام عليكم ورحمة الله أخى ياسر العربى بارك الله فيك بالنسبة للكودين Private Sub Worksheet_Activate() Application.CommandBars("Ply").Enabled = False End Sub Private Sub Worksheet_Deactivate() Application.CommandBars("Ply").Enabled = True End Sub جرب الاتى : ضع الكودين فى حدث الشيت 1 احفظ الملف وأنت على الشيت1 عشان لما يفتح الملف يفتح على الشيت 1 عندما يفتح الملف اعمل كليك يمين على الشيت 1 هتلاقي كليك يمين شغالة . فما الحل ؟

أخى وائل السلام عليكم عذرا على تأخر الرد بسبب سوء خدمة الانترنت عندى فقد حاولت بالامس الرد عليك فلم أستطع أخى وائل تم تحقيق طلبك فى موضوعى الجديد حماية تلقائية للبيانات بكل أوراق العمل عدا نطاقات محددة قابلة للتعديل بكلمة سر على الرابط http://www.officena.net/ib/topic/64457-حماية-تلقائية-للبيانات-بكل-أوراق-العمل-عدا-نطاقات-محددة-قابلة-للتعديل-بكلمة-سر/ لكى تعم الفائدة على الجميع تقبل تحياتى

السلام عليكم ورحمة الله وبركاته تناولت فى الفترة الماضية مايأتى حماية للشيت ما عدا نطاق محدد أو Protect Sheet Expect Range على الرابط http://www.officena.net/ib/topic/64169-حماية-للشيت-ما-عدا-نطاق-محدد-أو-protect-sheet-expect-range/ حماية كل أوراق العمل ما عدا نطاقات محددة أو Protect All Sheets Expect Ranges على الرابط http://www.officena.net/ib/topic/64193-حماية-كل-أوراق-العمل-ما-عدا-نطاقات-محددة-أو-protect-all-sheets-expect-ranges/ واليوم أقدم لكم حماية تلقائية للبيانات بمجرد فتح الملف لكل أوراق العمل مع استثناء نطاقات محددة قابلة لتعديل البيانات بها و بكلمة سر كلمة السر هى unloock ( ممكن تغييرها من الكود ) وهذا بناء على طلب أخونا وائل الأسيوطى الكود وعليه الشرح Dim sh As Worksheet Private Sub Workbook_Activate() ' Auto Protect Workbook Expect Ranges ' by mokhtar 25/10/2015 With Application .DisplayAlerts = False ' تعطيل التنبيهات .ScreenUpdating = False ' تعطيل تحديث الشاشة For Each sh In Worksheets ' لكل شيت فى الاوراراق If sh.ProtectContents = True Then ' اذا كان الشيت محميا فان ' لا تفعل شيئا Else ' واذا لم يكن محميا sh.Protect ' اجعل الشيت محميا End If ' انهاء الشرط Next sh ' الشيت التالى ActiveWorkbook.Save ' حفظ .DisplayAlerts = True ' اعادة تشغيل التنبيهات .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة End With End Sub Private Sub Workbook_Open() With Application .DisplayAlerts = False ' تعطيل التنبيهات .ScreenUpdating = False ' تعطيل تحديث الشاشة On Error Resume Next ' فى حالة حدوث خطأ تجاهله وانتقل للأمر التالى ' حلقة تكرارية للتعامل مع كل شيت فى الملف For Each sh In Worksheets ' اذا كانت محتويات الشيت محمية فان If sh.ProtectContents = True Then ' اجعل الشيت غير محمياً sh.Unprotect ' حلقة تكرارية لحذف جميع النطاقات المسموح يتعديلها فى الشيت For i = 1 To sh.Protection.AllowEditRanges.Count Debug.Print sh.Protection.AllowEditRanges(i) sh.Protection.AllowEditRanges(i).Delete Next i ' انهاء الحلقة التكرارية ' اضافة النطاقات المسموح بتعديلها أثناء حماية الشيت Sheets("Sheet1").Protection.AllowEditRanges.Add Title:="mokhtar1", Range:=Range("A18:G29"), Password:="unloock" ' اضافة النطاق فى الورقة الاولى Sheets("Sheet2").Protection.AllowEditRanges.Add Title:="mokhtar2", Range:=Range("F6,H7,D8,F14,H14"), Password:="unloock" ' اضافة النطاق فى الورقة الثانية Sheets("Sheet3").Protection.AllowEditRanges.Add Title:="mokhtar3", Range:=Range("D2,F3,D6,B8,F11,B14,D14"), Password:="unloock" ' اضافة النطاق فى الورقة الثالثة Sheets("Sheet4").Protection.AllowEditRanges.Add Title:="mokhtar4", Range:=Range("F10:F23"), Password:="unloock" ' اضافة النطاق فى الورقة الرابعة Else sh.Protect End If ' انهاء الشرط Next sh ' انهاء الحلقة التكرارية .DisplayAlerts = True ' اعادة تشغيل التنبيهات .ScreenUpdating = True ' اعادة تشغيل تحديث الشاشة End With End Sub المرفق للتجربة تحياتى والسلام عليكم Auto Protect Workbook Expect Ranges By Mokhtar.rar

أخى الزيارى

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

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

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