علي الشيخ

السلام عليكم أخي الكريم اتفضل شوف المرفق ان شاء الله يكون الملطوب في الورق1 الخلايا باللون الأزرق لا تقم بالتعديل عليها الخلايا التي ستقوم بالتعديل عليها هي تاريخ بداية العمل تاريخ نهاية العمل الراتب الأساسي " الخلية باللون الأحمر فقط اللي هي E25" والباقي يتغير تلقائيا أيضا تم إلغاء أو عدم حساب ما هو فوق السنة الصحيحة بمعنى تم التقريب لأقرب رقم صحيح للأصغر بمعنى مثلا الموظف اشتغل 10 سنوات ونص السنة سيتم فقط محاسبته على 10 سنوات حتى لو عمل مثلا 15 سنة و11 شهر سيتم احتساب 15 سنة فقط بدون النظر إلى الشهور مباشرة الاموال بالكامل.rar

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

ربنا يكرمك أخي والعفو انت تقصد إنك تقسم المعادلة بحيث يحسب كل عدد سنوات على حدى زي ما انت عامل في الشيت الأول؟ وكمان بالنسبة للكسور متأكد انهم يحسبوا على السنوات بس؟ يعني لو موظف اشتغل 10 سنوات و 11 شهر مش هيتم إحتساب المكافاة على 11 شهر؟ لان الكسور هنا تمثل الشهور والأيام يعني مثلا 10.5 تعني عشر سنوات و 6 أشهر وهكذا وأقدر الغيلك الكسور بس إنت اتأكد من الجزئية دي

السلام عليكم ورحمة الله أخي الفاضل يفضل إرفاق نموذج مصغر للملف كما أشار أستاذ علاء وأيضا كحل سريع على حسب فهمي خلي الخلية اللي فيها المعادلة بتاعك Vlookup تنسيقها يكون Short Date وتتحل المشكلة ان شاء الله

السلام عليكم أتفضل أخي شوف الملف المرفق وبالنسبة للأكواد في الملف الكود التالي في ThisworkBook الكود التالي يعمل على إضافة القائمة لكليك يمين في ملف الإكسل المحدد ولكي يتم الإضافة لكل ملفات الإكسل شوف الكود اللي في نهاية الرد Private Sub Workbook_Activate() Call AddToCellMenu End Sub Private Sub Workbook_Deactivate() Call DeleteFromCellMenu End Sub ثم قم بإدارج موديول عادي وانسخ فيه الكود التالي الكود يحتوي على 3 ماكرو كل واحد يعمل على تغيير حالة الحروف في باللغة الإنجليزية من حروف كبيرة إلى صغيرة إلى حسب الجملة A - a - Ali Sub AddToCellMenu() Dim ContextMenu As CommandBar Dim MySubMenu As CommandBarControl 'Delete the controls first to avoid duplicates Call DeleteFromCellMenu 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Add one built-in button(Save = 3)to the cell menu ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1 'Add one custom button to the Cell menu With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro" .FaceId = 59 .Caption = "Toggle Case Upper/Lower/Proper" .Tag = "My_Cell_Control_Tag" End With 'Add custom menu with three buttons Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3) With MySubMenu .Caption = "Case Menu" .Tag = "My_Cell_Control_Tag" With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro" .FaceId = 100 .Caption = "Upper Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro" .FaceId = 91 .Caption = "Lower Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro" .FaceId = 95 .Caption = "Proper Case" End With End With 'Add seperator to the Cell menu ContextMenu.Controls(4).BeginGroup = True End Sub Sub DeleteFromCellMenu() Dim ContextMenu As CommandBar Dim ctrl As CommandBarControl 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Delete custom controls with the Tag : My_Cell_Control_Tag For Each ctrl In ContextMenu.Controls If ctrl.Tag = "My_Cell_Control_Tag" Then ctrl.Delete End If Next ctrl 'Delete built-in Save button On Error Resume Next ContextMenu.FindControl(ID:=3).Delete On Error GoTo 0 End Sub Sub ToggleCaseMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells Select Case cell.Value Case UCase(cell.Value): cell.Value = LCase(cell.Value) Case LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase) Case Else: cell.Value = UCase(cell.Value) End Select Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub UpperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = UCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub LowerMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = LCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub ProperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = StrConv(cell.Value, vbProperCase) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub اذا اردت ظهور القائمة في كل ملفات الإكسل يمكنك حذف السطرين التاليين من الكود الأول Private Sub Workbook_Deactivate() Call DeleteFromCellMenu Book123.rar

السلام عليكم مرحبا أخي اتفضل شوف الملف المرفق أنا عملت في الورقة 2 كل المطلوب ولكن في معادلة واحدة ما عليك إلا إدخال تاريخ بداية الخدمة وتاريخ انتهاء خدمة الموظف والراتب الأساسي + البدلات وسيتم إحتساب مكافاة نهاية الخدمة بناء على الشروط اللي انت موضحها المعادلة المستخدمة = IF(C2<=4,(B8*4),IF(C2<=7,(((C2-4)*(B8*1.5))+(4*B8)),IF(C2<=10,((((4*B8)+(3*B8*1.5)+((C2-7)*(B8*2))))),IF(C2<=15,(((((4*B8)+(3*B8*1.5)+(3*B8*2)+((C2-10)*(B8*2.5)))))),IF(C2>15,(((((4*B8)+(3*B8*1.5)+(3*B8*2)+(B8*5*2.5)+((C2-15)*(B8*3))))))))))) مباشرة الاموال بالكامل.rar

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

السلام عليكم ورحمة الله وبركاته مرحبا أخي الكريم انا فهمت اللي إنت كاتبه في الملف بس المطلوب نفس مش واضح بالنسبة لي أي لوت نمبر اللي انت عاوزه يظهر في المكان المخصص في حين ان لكل صنف أكتر من لوت نمبر واحد وضحلي شوية لو أمكن

السلام عليكم وجمعة مباركة بإذن الله اتفضل أخي انا ارفقت لك الملف وايضا جرب انك في المعادلات السابقة تستبدل الفاصلة بفاصلة منقوطة ( حرف ك والكيبورد بالإنجليزية) كالتالي المعادلة الحالية =DATEDIF(C11,G11,"y") المعادلة الجديدة =DATEDIF(C11;G11;"y") مباشرة الاموال 2015.rar

جزاك الله خيرا أستاذ ياسر وجعله في ميزان حسناتك

السلام عليكم أخي بعتذر فهمت غلط طيب لو تقصد مثلا الفترة اللي اشتغلها الموظف من إلى لتكون كالتالي 10 سنة 5 شهور 25 يوم تقدر تستخدم المعادلة التالية لحساب السنة حيث C11 تاريخ بداية الفترة G11 تاريخ نهاية الفترة في خانة السنة ضع المعادلة التالية =DATEDIF(C11,G11,"y") خانة الشهر ضع المعادلة التالية =DATEDIF(C11,G11,"ym") خانة اليوم ضع المعادلة التالية =DATEDIF(C11,G11,"yd") وان شاء الله يكون هو ده المطلوب

السلام عليكم شوف المرفق أخي ان شاء الله يكون المطلوب وبدون معادلات أو شئ بالطريقة التقليدية البسيطة وان شاء الله يفي بالغرض مباشرة الاموال 2015.rar

أتمنى من الله أن تكونوا جميعا بالف خير حبيت أطرح موضوع أكيد ليس بالجديد ولكنه مفيد أحيانا أتمنى الإفادة للجميع الموضوع هو عن فك حماية أوراق العمل Worksheets في أي مستند فالمرفق يحتوي على إضافة يمكن إضافتها للإكسل لتكون ثابته في كل ملفات الإكسل ما عليك إلا أن تفتح الملف الذي به الأوراق محمية وتضغط على الزر الذي سيتم تعيينه في الـ Ribbon وسيتم فك التشفير في لحظات http://forum.tawwat.com/images-topics/images/fa/0042.gif أولا : الكود المستخدم Public Sub ExcelPasswordRemover() Dim Mess As String, Header As String Dim Credit As String Dim RepBack As String, AllClear As String Dim PWord1 As String Dim ShTag As Boolean, WinTag As Boolean Dim w1 As Worksheet, w2 As Worksheet Dim i As Integer, j As Integer, k As Integer, l As Integer Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer Application.ScreenUpdating = False Header = "Ýß ÊÔÝíÑ ÕÝÍÇÊ ÇáÅßÓá" Credit = vbNewLine & vbNewLine & "ãäÊÏíÇÊ ÃæÝíÓäÇ ÇáÊÚáíãíÉ" RepBack = vbNewLine & vbNewLine & "www.officena.com" With ActiveWorkbook WinTag = .ProtectStructure Or .ProtectWindows End With ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag And Not WinTag Then Mess = vbNewLine & "áÇ íæÌÏ ßáãÉ ÓÑ ááÕÝÍÇÊ ÇáÍÇáíÉ" & vbNewLine & Credit MsgBox Mess, vbInformation, Header Exit Sub End If Mess = "ÓæÝ ÊÓÊÛÑÞ ÚãáíÉ Ýß ÇáÍãÇíÉ ËæÇäí ãÚÏæÏÉ" & _ vbNewLine & "OK ÅÖÛØ " & vbNewLine & "æÅäÊÙÑ ÍÊì íÊã Ýß ÇáÍãÇíÉ " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header If Not WinTag Then Mess = "" & _ "" & vbNewLine & _ "ÌÇÑí ÍÐÝ ÇáÍãÇíÉ " & _ Credit MsgBox Mess, vbInformation, Header Else On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 With ActiveWorkbook .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If .ProtectStructure = False And _ .ProtectWindows = False Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "You had a Worksheet Structure or " & vbNewLine & _ Credit MsgBox Mess, vbInformation, Header Exit Do End If End With Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If If WinTag And Not ShTag Then Mess = "Only structure / windows protected with " & vbNewLine & _ "the password that was just found." & vbNewLine & _ AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If On Error Resume Next For Each w1 In Worksheets w1.Unprotect PWord1 Next w1 On Error GoTo 0 ShTag = False For Each w1 In Worksheets ShTag = ShTag Or w1.ProtectContents Next w1 If Not ShTag Then Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header Exit Sub End If For Each w1 In Worksheets With w1 If .ProtectContents Then On Error Resume Next Do For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 .Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If Not .ProtectContents Then PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _ Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Mess = "Êã ÍÐÝ ßáãÉ ÇáÓÑ " & _ Credit MsgBox Mess, vbInformation, Header For Each w2 In Worksheets w2.Unprotect PWord1 Next w2 Exit Do End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next Loop Until True On Error GoTo 0 End If End With Next w1 Mess = AllClear & Credit & RepBack MsgBox Mess, vbInformation, Header End Sub يمكن استخدامه كماكرو عادي أو يمكن استخدامه كإضافة للإكسل لتكون ثابته في كل الملفات Addin طريقة إضافة الـ Addins للإكسل كالتالي بعد فتح أي ملف إكسل ومن علامة الإكسل في أقصى اليسار نضغط عليها ثم نضغط Excel Options ثم من القائمة نضغط على Addin ثم نضغط Go ونختار الإضافة من المكان الذي تم حفظها فيه ثانيا إظهار الإضافة في الـ Ribbon وأخير قم بفتح أي ملف به صفحات محمية بباسورد وأضغط على الإضافة كما موضحه في الصورة التالية وسيتم فك الحماية بمشية الله Sheet Password Remover AddIn.rar

جزاكم الله خيرا على مروركم الكريم

شكرا لك أخي وجزاك الله خيرا

جزاك الله خيرا أستاذ محمد وفي انتظار المزيد من الحالات العملية المفيدة جدا جدا جدا صراحة الله يجزاك خير

أتمنى من الله أن تكونوا جميعا بخير وصحة وسلامه وكل عام وأنتم بخير بمناسبة قرب الشهر المبارك واللهم بلغنا رمضان . حبيت أقدم موضوع بسيط ومفيد في بعض الأحيان مع تطبيق تجدونه في المرفق فكرة الموضوع: هي إن لو عندي يوزرفورم خاص بالإدخال أو التعديل أو الحذف أو البحث أو مهما كان طبيعة عمل اليوزرفورم أقدر إن من خلال الفورم الحالي إني اعمل توليد لعدد لا نهائي من اليوزفورم وكل منهم يستخدم أيضا في الإدخال أو في أي من الأغراض التي من أجلها تم إنشاء اليوزر فورم الأساسي بمعنى أخر وإيضاحا للنموذج المرفق هو إني عندي فورم بحث عن طريق الليست بوكس بكتب كلمة للبحث في النموذج الأساسي ثم أضغط على زر " إضافة نموذج جديد" هيظهر فورم جديد نسخة من الأساسي أكتب فيه كلمة بحث جديدة ويظل عندي النموذجان وفي كل منهما كلمة بحث ونتائج مختلفة وهكذا والمرفق يوضح أكتر إن شاء الله تكون فكرة مفيدة لكل اللي هيستخدمها ودمت في رعاية الله Repeated Userform.rar

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

اتفضل أخي في المرفق تم حماية محرر الأكواد للملف بنفس الباسورد اللي انت كاتبه 123456 والطريقة انك بتفتح محرر الأكواد وكليك يمين على اسم البروجيكت ثم تضغط VBAProject Properties وتدخل على Protection تضع علامه في Lock Project وتكتب الباسورد وتكررها ومن ثم حفظ الملف الجزئية الأخرى بتاعه نسخ الملف إن شاء الله نلاقي لها حل وانتظر الأخوة بيفيدوك أكتر باذن الله md.rar

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

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

السلام عليكم أخي أنا عملتهالك بطريقة بدائية شوية حطيت قصاد كل أرقام السيارات في العمود G القيمة 0 واستخدمت دالتي Vlookup و IFERROR بحيث ان كل أرقام السيارات في العمود A سيتم البحث عن كل قيمة في هذا العمود هل هي موجودة في العمود G ولا لا لو موجودة يجيب القيمة اللي قصادها وهي 0 اللي اضفناه في الخطوة السابقة لو مش موجودة هيكتب القيمة من العمود B والدالة المستخدمة كالتلي =IFERROR(VLOOKUP(A3,$G$3:$H$8,2,FALSE),B3) والمرفق يوضح أكثر ان شاء الله لحد ما يدخل الإخوة ويقدموا حلول أفضل بإذن الله find.rar

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

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

أتمنى من الله ان تكونوا في تمام الصحة والعافية موضوع بسيط وجديد على البعض وفائدته أنه يعمل إنتقال من الفريمات الموجودة في اليوزر فورم بشكل غير تقليدي وسلس في المثال المرفق يوجد يوزر فورم وبه عدد 2 Frame ويتم الإنتقال من فريم للأخر بزر عادي ولكن طريقة الإنتقال هي موضوعنا الأكواد المستخدمة أكواد الـ UserForm يحتوي على 2 Command Button لإنتقال من فريم للأخر Option Explicit Private Sub CommandButton1_Click() While Frame2.Left > 6 Frame2.Left = Frame2.Left - 10 DoEvents Sleep 10 Wend End Sub Private Sub CommandButton2_Click() While Frame2.Left < 266 Frame2.Left = Frame2.Left + 10 DoEvents Sleep 10 Wend End Sub Private Sub UserForm_Initialize() Me.Width = 262 Frame2.Left = 266 Frame2.Top = 6 End Sub كود مستخدم في Module عادي Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) أتمنى يكون الموضوع خفيف وواضح والمرفق به التطبيق ودمتم في حفظ الله Sliding Form.rar