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

أخوتى فى الله الساهر و يوسُف بارك الله فيكما وشرُفت بمروركما وسعدتُ به تحياتى

أستاذ قيس بارك الله فيكم وتقبلّ دعاءكم أستاذى الفاضل محمد صالح ما كنت أدرى أن الكود خاص بكم الا الآن وإلا كنت أشرت أنه لك وفعلا أنا وجدته فى أحد كنترولات المدارس واحتفظت به عند الحاجة فقد أعجبنى الكود وخاصة أنه يفقط الدرجة و نصف الدرجة أما عن التعديل فأقترح على حضرتكم اضافة 0 فقد يحصل طالب على الصفر غـ فقد نجد طالب غائب فى مادة تعديل تفقيط الــ 1/2 يكتب فقط درجة ونصف والأصل فقط نصف درجة . تقبل تحياتى

تفضل أخى الكريم تفقيط رائع للدرجات الصحيحة ونصف الدرجة لأى عدد ولكن بدون الصفر قد يفيدك كان الله فى العون تحياتى أخوك مختار حسين تفقط رائع للدرجات الصحيحة ونصف الدرجة.rar

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

خلاص بقى طالما الحل عجبك أنهى الموضوع ولا تنسونا فى دعائكم

السلام عليكم الله وبركاته بداية أقدم كل التحية والتفدير والاحترام الى أساتذتى الكرام وأخص بالذكر الأستاذ عبدالله باقشير الذى أوحى إلىّ بهذه الدالة فقد قدم لنا الأستاذ الفاضل دالة للجمع بناء على لون الخلية وهى : Function kh_SumColor(RngColor As Range) As Double Dim cel As Range Dim sm As Double For Each cel In RngColor If cel.Interior.Color = Application.Caller.Interior.Color Then sm = sm + Val(cel) Next kh_SumColor = sm End Function وعن طريق الصدفة وجدت طلبا فى أحد المنتديات الأجنبية التى أشترك فيها يسأل عن Sum Cells by Font Color فجااء ببالى لماذا لا نستفيد من دالة أستاذى الفاضل ولكن بطريقة أخرى وهى الجمع بناء على لون الخط فأصبحت الدالة بهذا الشكل : Function MOKHTAR_SumFontColor(RngFontColor As Range) As Double Dim cel As Range Dim MOKH As Double For Each cel In RngFontColor If cel.Font.Color = Application.Caller.Font.Color Then MOKH = MOKH + Val(cel) Next MOKHTAR_SumFontColor = MOKH End Function وبمجرد أن أنتهيت من المطلوب قررت وضعه هنا فى المنتدى ليستفيد منه الزملاء أرجو من أستاذى أن يعذرنى على هذا الاقتباس فقد ينفع يوما بعض الناس . تقبلوا جميعاً تحياتى وهذا مرفق للدالة Sum Cells by Font Color.rar

تفضل أخى الكريم عله يفى بالغرض فى المرفق الأول أدخل عدد مرات الطباعة تم أدخل عدد الصفحات 1 للصفحة الاولى 2 تعنى أول صفحتين وهكذا فى المرفق الثانى أدخل عدد مرات الطباعة تم أدخل رقم الصفحة 1 للصفحة الاولى 2 للصفحة الثانية وهكذا ملحوظة : انقل زر استدعاء الفورم لأى ورقة عمل فى الملف وأى عملية طباعة ستكون على الورقة النشطة تحياتى recharche XD.rar recharche XD 2.rar

أستاذ خالد أقول لك بعد عملية بحث فى الانترنت أنه هناك فارق بين الجملتين Application.ScreenUpdating=False تستخدم لايقاف screen flickering أو وميض الشاشة واهتزازها أثناء عمل الكود أما Debug.Assert Application.ScreenUpdating تستخدم فى ايقاف كود به قيمة خاطئة فاذا كان فى الكود قيمة خاطئة فهذه الجملة بتوقف عمل الكود فى المرفق أربعة أمثلة لأكواد مختلفة الثلاثة الأولى تعمل أما الأخير لا يعمل بسبب وجود الجملة Debug.Assert Application.ScreenUpdating دى مع كلمة false فى الكود بعكس الكود الثالث هذا ما أعرفه انتظر رأى باقى الزملاء عل وعسى تكون هناك اجابات أخرى تحياتى لك للأسف تعذر رفع الملف لأسباب لا أعرفها لذلك اليك الأكواد Sub test1() Application.ScreenUpdating = True MsgBox Application.ScreenUpdating End Sub Sub test2() Application.ScreenUpdating = False MsgBox Application.ScreenUpdating End Sub Sub test3() Application.ScreenUpdating = True Debug.Assert Application.ScreenUpdating MsgBox Application.ScreenUpdating End Sub Sub test4() Application.ScreenUpdating = False Debug.Assert Application.ScreenUpdating 'الكود توقف لان به قيمة حاطئة بعكس الكود الثالث MsgBox Application.ScreenUpdating End Sub تحياتى لك

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

أستاذى الفاضل أشكرك على الهدية . لك منى كل تحية وتقدير واحترام تلميذك / مختار حسين محمود

الحمد لله أستاذى الفاضل أننا توصلنا الى ذلك حقيقةً سيدى الفاضل لم أتمكن بنفسى من التعديل وانما بمساعدة Mr. Jan Karel Pieterse أحد مطورى شركة مايكروسوفت .الرجل أعطانى رابط فى موقعه الخاص : http://www.jkp-ads.com/articles/apideclarations.asp وبصراحة أنا خدتها من قصيرها وطلبت منه التعديل عشان أضمن ازاى بيحوّل التصريحات لكى تعمل فى ويندوز 32 و 64 ولم يتأخر الرجل مشكورا . وبإذن الله سأحاول فى الفترة القادمة إزاى تم تحويل تصريحات تعمل فى 32 الى تصريحات تعمل فى 32 و64 طبقا للرابط المذكور. ويبدو أن كلمة السر عند مايكروسوفت فى التعديل الذى أصدرته لـ Win32API.txt هذا التعديل هو Office2010Win32API_PtrSafe حسب ما فهمته من الرابط المذكور ملحوظة : مرفق حضرتك بعمل على win_ 32 bit and win_64 bit تحياتى لك Win32API_PtrSafe.rar

د / ياسر أشكرك على الدالة القيصرية دى كما أشكرك على الشرح الجميل للعملية وإثراءك للمنتدى بكل جديد تقبل تحياتى

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

أشكرك أخى وأستاذى العزيز ربنا يكرمنا بحد يكون عنده 64 وإلا ......ولا أقولك بلاش نصبر شويه حاولت أبعت على الخاص بتاع أستاذنا دغيدى لقيته مغلق لأنه أول من طلب ذلك ولا أعرف كيف أبلغه تحياتى لك

أشكرك أخى وأستاذى ياسر وأنت دائما على بالى وكل الأخوة الذين أتعلم منهم أكيد 2013 فيه زيادة عن 2010 لكن لما سطبته مش عارف ليه ومن غير سبب رجعت لـ 2010 ألق نظرة على :http://www.officena.net/ib/index.php?showtopic=59963 مشاركة 12

والله مشغول أخى ياسر فى موضوع القرائية وادخال البيانات لقاعدة الوزارة رابط التراجع عن تنفيذ الماكرو http://www.officena.net/ib/index.php?showtopic=57976 بعيد عن الموضوع ده شوفت الموضوع ده مشاركة 12 عايز رد سريع لأن عندى win7_32 الكود بالفعل يعمل على win7_32 وأريد التأكد من عمل الكود على win7_64 http://www.officena.net/ib/index.php?showtopic=59963

السلام عليكم ورحمة الله وبركاته اخوانى الكود فى المرفق السابق يعمل مع ويندوز 32 ولا يعمل مع ويندوز 64 الحمد لله وصلت الى التعديل المناسب بمساعدة Mr. Jan Karel Pieterse لكى يعمل الكود مع الأخوة الذين يعملون على ويندوز 64 برجاء تجربة الكود التالى واخبارى بالنتيجة Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetDriveType Lib "kernel32" Alias _ "GetDriveTypeA" (ByVal sDrive As String) As LongPtr Private Declare PtrSafe Function GetDiskFreeSpaceEx Lib "kernel32" Alias _ "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _ lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As _ Currency, lpTotalNumberOfFreeBytes As Currency) As LongPtr #Else Private Declare Function GetDriveType Lib "kernel32" Alias _ "GetDriveTypeA" (ByVal sDrive As String) As Long Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" _ Alias "GetDiskFreeSpaceExA" (ByVal lpDirectoryName As String, _ lpFreeBytesAvailableToCaller As Currency, _ lpTotalNumberOfBytes As Currency, _ lpTotalNumberOfFreeBytes As Currency) As Long #End If Function DriveSize(DriveLetter As String) As String #If VBA7 Then Dim Status As LongPtr #Else Dim Status As Long #End If Dim TotalBytes As Currency Dim FreeBytes As Currency Dim BytesAvailableToCaller As Currency Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _ BytesAvailableToCaller, TotalBytes, FreeBytes) If Status <> 0 Then DriveSize = TotalBytes * 10000 Else DriveSize = "" End If End Function Function DriveSpaceFree(DriveLetter As String) As String #If VBA7 Then Dim Status As LongPtr #Else Dim Status As Long #End If Dim TotalBytes As Currency Dim FreeBytes As Currency Dim BytesAvailableToCaller As Currency Status = GetDiskFreeSpaceEx(DriveLetter & ":\", _ BytesAvailableToCaller, TotalBytes, FreeBytes) If Status <> 0 Then DriveSpaceFree = FreeBytes * 10000 Else DriveSpaceFree = "" End If End Function Function DriveType(DriveLetter As String) As String ' Returns a string that describes the type of drive of DriveLetter DriveLetter = Left(DriveLetter, 1) & ":\" Select Case GetDriveType(DriveLetter) Case 0: DriveType = "Unknown" Case 1: DriveType = "Non-existent" Case 2: DriveType = "Removable drive" Case 3: DriveType = "Fixed drive" Case 4: DriveType = "Network drive" Case 5: DriveType = "CD-ROM drive" Case 6: DriveType = "RAM disk" Case Else: DriveType = "Unknown drive type" End Select End Function Sub ShowAllDrives() Dim LetterCode As Long Dim Row As Long Dim DT As String Range("A1:D1") = Array("Drive", "Type", "Total Bytes", "Free Bytes") Row = 2 For LetterCode = 65 To 90 DT = DriveType(Chr(LetterCode)) If DT <> "Non-existent" Then Cells(Row, 1) = Chr(LetterCode) & ":\" Cells(Row, 2) = DT Cells(Row, 3) = DriveSize(Chr(LetterCode)) Cells(Row, 4) = DriveSpaceFree(Chr(LetterCode)) Row = Row + 1 End If Next LetterCode End Sub أرجو من الأخوة الذين يعملون على ويندوز 64 اخبارى بالنتيجة تقبل الله منا ومنكم صالح الأعمال

بارك الله فيكم أخى وأستاذى ياسر واثراءً للموضوع إليكم هذا الرابط : http://www.officena.net/ib/index.php?showtopic=57976 تحياتى لكم

وجازاكم خيرا أعتذر عن تأخر الرد تحياتى لك

متأسف على تأخر الرد ببساطة خالص اعمل حماية للشيتات حسب نوعها إدخال تدقيق طباعة من قائمة review ثم من protect sheet أدخل كلمة سر ثم أكدها مرة أخرى ثم حفظ .خلى شيتات الادخال لوحدها بكلمة سر واحدة بالنسبة للطباعة يمكن عملها بكلمة سر اللى يعرفها يستطيع الطباعة من خلال الكود التالى Private Sub Workbook_BeforePrint(Cancel As Boolean) Dim Password As String Dim i As Integer i = 0 Do Until i = 3 ' عدد محاولات ادخال كلمة سر الطباعة Password = InputBox("Password required for printing!", "Password", "Enter password here") If Password <> "123" Then MsgBox "Worksheets can not " & "be printed - See CSR with questions.", vbCritical, "Incorect Password" i = i + 1 Else Exit Sub End If Loop Cancel = True End Sub لاحظ يا احمد أن الكود ده نضعه فى حدث المصنف كلمة السر 123 يمكنك تغييرها فى الكود تحياتى لك

متأسف أخى يبدو أن خطأ ما حدث فى رفع الملف الخاص بالمشاركة رقم 3 vlookup picture.rar

تمام أوى اشتغل الكود الأصلى ولكن البيانات طلعت بشكل يحتاج تنسيق وتعديل فى الكود تحياتى

أخى الدكتور ياسر أعمل ايـــــــــه والولادة كانت عسرة ؟! من البنج لحد ما المولود طلع 3 ساعات وأكتر حاولت فى المولود وعطيت اكسجين مفيش فايدة كان هيموت.منى ونشف دماغه وحلف ما هو نازل عند السطر ده : Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("Table1").Range مع أنى عامل اسم المدى Table1 ومفعل المكتبة !!! بس ربنا ستر وأقدرت أطلعه داهيه تطلع عينه زى ما طلع عينيه تفتكر ليـــــــــــــــــــــــه يا دكتور ياسر؟!

وهذا مثال آخرلاستدعاء الصورة من مجلد فى المرفق المجلد temp ضعه فى الـــ c اذا كنت تريد تغيير المسار انقل المجلد temp الى المسار الذى تريده وقم بالتعديل فى ملف الاكسل الورقة data تحياتى

تفضل أخى الكريم هذا النوذج show Images in a Cell based on a condition.rar