ابو تراب

تقبل شكري على اهتمامك الكريم بالكود اغلب الظن انه لم يتم تعيين قيمة لل Full name او Display Name في الصورة ادناه اسم الحساب هو Family بينما الاسم الكامل هو Sweet Heart غيرت قليلا في الكود ليعطي رسالة مرحبا للاسم الكامل او اسم المستخدم ارجوا ان ينجح هذه المرة Sub btnGetFullUserName() Dim Accounts As Object, User As Object Dim ComputerName As String Dim UserName As String ' الجهاز الحالي ComputerName = "." ' احصل على مرجع لحسابات الويندوز Set Accounts = GetObject("WinNT://" & ComputerName & "") ' فلتر الحسابات الى الاسماء Accounts.Filter = Array("user") ' افحص جميع الاسماء For Each User In Accounts ' تأكد ان المستخدم هو المستخدم الحالي للنظام If User.Name = Environ("Username") Then ' اعرض الاسم كاملا اذا وجد UserName = User.FullName If UserName = "" Then UserName = User.Name MsgBox "مرحبا " & UserName, vbInformation + vbMsgBoxRtlReading End If Next End Sub تقبل تحيايتي

كود لعرض الاسم كاملا لمستخدم الويندوز الحالي مرفق مثال Sub btnGetFullUserName() Dim Accounts As Object, User As Object Dim ComputerName As String ' الجهاز الحالي ComputerName = "." ' احصل على مرجع لحسابات الويندوز Set Accounts = GetObject("WinNT://" & ComputerName & "") ' فلتر الحسابات حسب الاسماء Accounts.Filter = Array("user") ' افحص جميع الاسماء For Each User In Accounts ' تأكد ان المستخدم هو المستخدم الحالي للنظام If User.Name = Environ("Username") Then ' اعرض الاسم كاملا اذا وجد MsgBox "مرحبا " & User.FullName, vbInformation + vbMsgBoxRtlReading End If Next End Sub Get Full user name.zip

عدلت لك الكود بحيث تكتب العدد 16 او 16.15 جرب و خبرنا حضور وانصراف الموظفين.zip

وعليكم السلام و رحمة الله و بركاته فقط غيرت تنسيق الخلاياء الى تنسيق وقت و عدلت على بعض الادخالات للتوافق مثلا عدلت 17.0 الى 17:00 جرب المرفق حضور وانصراف الموظفين.zip

تفضل اخي Example.zip

اكواد التعامل مع التعليقات او Comments للتوضيح اكثر ارفق مثال Sub btnA1Comment() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A1].Comment ' اذا كان لا يوجد تعليق للخلية ..اضف تعليق If cmt Is Nothing Then ' اضف تعليق و عين المرجع Set cmt = [A1].AddComment cmt.Text Text:="هذا تعليق في الخلية A1" & vbCrLf & vbCrLf & "تعليق في سطر جديد" End If End Sub Sub btnA1EditComment() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A1].Comment ' اذا كان لا يوجد تعليق للخلية ..اضف تعليق If Not cmt Is Nothing Then 'افتح التعليق في وضع التحرير [A1].Select SendKeys "+{F2}" End If End Sub Sub btnDeleteA1Comment() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A1].Comment ' اذا كان لا يوجد تعليق للخلية ..اضف تعليق If Not cmt Is Nothing Then ' احذف التعليق cmt.Delete End If End Sub Sub btnHideAllComments() Dim cmt As Comment For Each cmt In ActiveSheet.Comments cmt.Visible = False Next End Sub Sub btnDeleteAllComments() Dim cmt As Comment For Each cmt In ActiveSheet.Comments cmt.Delete Next End Sub Sub btnA2Comment() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A2].Comment ' اذا كان لا يوجد تعليق للخلية ..اضف تعليق If cmt Is Nothing Then ' اضف تعليق و عين المرجع Set cmt = [A2].AddComment cmt.Text Text:="هذا تعليق في الخلية A2" End If ' اظهر التعليق و اختاره cmt.Visible = True cmt.Shape.Select End Sub Sub btnA3Comment() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A3].Comment ' اذا كان لا يوجد تعليق للخلية ..اضف تعليق If cmt Is Nothing Then ' اضف تعليق و عين المرجع Set cmt = [A3].AddComment cmt.Text Text:="تحذير" & vbCrLf & "هذا تعليق في الخلية A3" ' تنسيق التعليق With cmt.Shape.TextFrame ' تنسيق الخط .Characters.Font.Name = "Times New Roman" .Characters.Font.Size = 11 .Characters.Font.Bold = False .Characters.Font.ColorIndex = 0 'تلوين السطر الاول من التعليق .Characters(1, 5).Font.Color = vbRed .Characters(1, 5).Font.Bold = True End With End If End Sub Sub btnCPI() Dim cmt As Comment ' عين مرجع للكائن تعليق للخلية Set cmt = [A4].Comment If cmt Is Nothing Then Set cmt = [A4].AddComment With cmt .Text Text:="" ' اضافة صورة .Shape.Fill.UserPicture ThisWorkbook.Path & "\CPI.jpg" .Visible = False End With End If End Sub Comments.zip

بعد اذن السادة الكرام هذه محاولة بأستخدام الدالة Mod احتساب 3.zip

هلا بيك بالنسبة للرقم 7 فهو يمثل يومي الجمعة و السبت (ايام العطل) اما لماذا انقصت و احد فسبب ليوافق طريقتك في الحساب مثال: اول يوم دراسي هو 4-Jan فأذا كانت قيمة عدد ايام الدراسة يوم واحد فان الدالة Workday.Int ستعتبر ان الحساب يبدأ بعد تاريخ 4-Jan اي ستعيد 5-Jan الا انك تعتبر 4-Jan يوم من ايام الدراسة و لهذا وجب تنقيص بيوم واحد.

وعليكم السلام و رحمة الله و بركاته الطريقة الاسرع انك تعكس الاعمدة جرب المرفق كريم.zip

كود لفتح مجلد مثال: اذا افترضنا ان المدى من A1 الى A5 يحتوي على اسماء المجلدات في المسار في المسار C:\test فلفتح المجلد المعني بمجرد اختيار خلية من خلاياء المدى اعلاه .. نكتب الكود التالي في حدث الصفحة: Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' تأكد ان الخلية تقع على المدى المطلوب و ان الخلية لديها قيمة If Not Intersect(Target, Range("A1:A5")) Is Nothing And Target.Count() = 1 Then If Target.Value <> "" Then Shell "cmd /c start C:\Test\" & Target.Value, vbHide End If End Sub

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

وعليكم السلام ورحمة الله وبركاته افترض ان يوم الاجازة هو 5/1/2015 جرب المرفق ايام العمل.zip

اولا تقبل شكري على الاهتمام بهذا الكود للتوضيح الغرض من الدالة ليس الدالة نفسها (فالدالة SUM تكفي و زيادة) و لكن الغرض الاساسي هواعطاء مثال على عمل اي دالة قادرة على قبول و سيط او اكثر دون تحديد عددها. على كلا اذا كان هناك ميزة للدالة فربما في ال VBA فالدالة WorksheetFunction.Sum تقبل الى حد 30 وسيط. من ناحيت الخطأ فسبب ان الدالة سترجع خطأ اذا وجدت اي وسيط ليس برقم حتى لوكان NULL. في رايي انه يمكن القياس على هذه الدالة لانشاء دوال اكثر ملائمة .. مثلا ;كتبت دالة مستفيدا من فكرة الكود بحيت تعمل على تعبئة الخلاياء باي نوع من البيانات الكود مع كود الاختبار Sub Fill(R As Range, ParamArray Values() As Variant) Dim i As Integer For i = LBound(Values) To UBound(Values) R.Offset(0, i).Value = Values(i) Next i End Sub Sub test() Fill [A1], 100, "This", True, -25.5 End Sub

السلام عليكم شكرا الله للاستاذ ياسر و للاعضاء الكرام على جهودهم الرائعة لانجاح المشروع المميز فكرة الكود هو كيفية عمل دالة تقبل عدد لا محدود من الوسطاء. للتوضيح كتبت مثال لدالة جمع بأسم Sum . لتحقيق ذلك تم استخدام المعرف ParamArray لتعريف مصفوفة وسطاء الدالة من نوع Variant في الاسفل تجد كود الدالة و اجراء اختبار لها بالتوفيق ' دالة تقبل عدد غير محدود من الوسطاء ' المثال هنا هو دالة جمع 'تم تعريق مصفوفة خاصة من نو فيريانت Function Sum(ParamArray Numbers() As Variant) As Double Dim i As Integer Dim Result As Double Result = 0# ' هنا نتأكد انه يوجد على الاقل وسيط واحد قد تم تمريره للدالة If Not UBound(Numbers) - LBound(Numbers) > -1 Then ' في حالة لم يمرر ولا وسيط ارسل خطأ و اوقف تنفيد الدالة Sum = CVErr(xlErrNull) Exit Function Else ' هنا مر على جميع وسطاء الدالة For i = LBound(Numbers) To UBound(Numbers) ' اختبر اذا كان الوسيط يمثل رقما If IsNumeric(Numbers(i)) Then Result = Result + Numbers(i) Else ' في حالة اكتشاف وسيط ليس برقم ارسل خطأ تنفيد و اوقف تنفيد الدالة Sum = CVErr(xlErrNum) Exit Function End If Next i End If ' في حالة نجاح تنفيدها حدث الدالة بقيمة الجمع Sum = Result End Function Sub test() MsgBox Sum(5) MsgBox Sum(5, 10) MsgBox Sum(5, -10, -13.25) End Sub

اكواد التعامل مع جداول الاكسل مرفق ملف للتوضيح Sub btnCreateTable() ' انشاء جدول و تعيين اول سطر كـ اسماء للحقول و اعطاء اسم للجدول ليسهل الوصول اليه Sheet1.ListObjects.Add(xlSrcRange, Range("A1:D9"), , xlYes).Name = "tblStudents" ' الغي الوان الخلفية و اعتمد تنسيق الجدول Range("tblStudents").Interior.ColorIndex = 0 ' الغي فلتر الجدول Range("tblStudents").AutoFilter End Sub Sub btnResetTable() ' الغي الجدول و عده لحالته الاولى (مدى) On Error Resume Next Sheet1.ListObjects("tblStudents").Unlist End Sub Sub btnSortTable() ' ترتيب اسطر الجدول على حسب الاسم With Sheet1.ListObjects("tblStudents").Sort .SortFields.Clear .SortFields.Add _ Key:=Range("tblStudents[[#ALL],[الاسم]]"), _ SortOn:=sortonvalues, _ Order:=xlAscending, _ DataOption:=xlSortNormal Range("tblStudents[#ALL]").Select .Header = xlYes .MatchCase = False .Orientation = xlSortColumns .SortMethod = xlPinYin .Apply End With End Sub Sub btnFilterTable() ' فلترة الحقل الاول (الاسم) و اظهار جميع الطلاب الذين اسمائهم عمر Range("tblStudents").AutoFilter Field:=1, Criteria1:="عمر" End Sub Tables.zip

السلام عليكم استاذ ياسر هذا كود لتنفيد التغييرات على الشيت في حالة حماية الشيت و مشاركة الملف...ارجوا ان يكون مفيدا تنفيذ الكود في حالة مشاركة ملف الاكسل Sub Button1_Click() بداية الجملة With علي الملف الحالي With ActiveWorkbook .الغاء ظهور رسائل اكسل Application.DisplayAlerts = False .تفعيل الوصول الحصري للملف .ExclusiveAccess .تفعيل ظهور رسائل اكسل Application.DisplayAlerts = True ازالة الحماية للورقة ActiveSheet.Unprotect 111 نسخ الخلية A1 في الخلية A2 [A2] = [A1] حماية الورقة ActiveSheet.Protect 111 . Application.DisplayAlerts = False .تفعيل متابعة التغييرات في الملف المشارك .KeepChangeHistory = True .تفعيل مشاركة الملف .SaveAs Filename:=ActiveWorkbook.FullName, AccessMode:=xlShared . Application.DisplayAlerts = True نهاية الجملة With End With End Sub تشغيل ماكرو في ملف مشارك.zip

شرح وافي و انيق ... ثمن الله جهودك استاذ محمد و جزاك الله عنا خيرا

هلا باخي ساهر يمكنك استخدام الدالة NetworkDays لهذا الغرض... لا تنسى ضبط اعدادات الويندوز على ان اول ايام الاسبوع هو الاحد للتوضيح اكثر انظر الصورة ملاحظة ====== الدالة ايضا يمكنها ان تخصم الاجازات اذا مررت لها مدى الاجازات في الوسيط الثالث للدالة

بعد اذن الاستاذ ياسر هذه محاولة اخرى لاثراء الموضوع ملاحظة: -------- عدلت الملف لاستعادة الاعدادات الافتراضية Enter التنقل بين الخلايا بالانتر حسب الترتيب.zip

الاستاذ bedonada ,و الاستاذ حليم .. شكرا جزيلا على مروركم العطر و كلماتكم الطيبة ان شاء الله اذا اسعف الوقت ساكمل الدالة ببقية الخيارات تحياتي

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

مميز فعلا ... شكرا الله لك اساذ الجموعي على مشاركتنا البرنامج اؤيد اخي ريان في طلبه .. خاصية نسخ الرمز ستكن فيدة فعلا

في هذه الحالة يبقى احتمال اعدادات الانترنت للجهاز و خصوصا محرر HTML او الـ HTML Editor جرب الاتي: 1 - ادخل على اعدادات الانترنت من لوحة التحكم Control Panel --> Internet Options 2 - اختر التبويب Programs هنا اختر الاكسل لـ HTML Editor و اضغط على Apply و بعدها الغي الخيار الاكسل تبع HTML Editor و ختر OK لمزيد من التوضيح انظر الصورة:

هلا و غلا باستاذنا الغالي الصقر .. تشرفت بمروك العطر تحياتي لشخصك الكريم

ممكن معلومات اكثر هل جهازك مربوط بشبكة في العمل ام انه جهاز في البيت هل دخلت باسم المستخدم المدير Administrator ام بحساب اخر ليس له صلاحيات المدير. اغلب الضن المشكلة بسبب اعدادات ال Group policy تبع الويندوز. ما هو اصدار الويندوز المحمل لديك