علي الشيخ

مايو 30, 2015

السلام عليكم أخي الكريم

اتفضل شوف المرفق ان شاء الله يكون الملطوب

في الورق1

الخلايا باللون الأزرق لا تقم بالتعديل عليها

الخلايا التي ستقوم بالتعديل عليها هي

تاريخ بداية العمل

تاريخ نهاية العمل

الراتب الأساسي " الخلية باللون الأحمر فقط اللي هي E25" والباقي يتغير تلقائيا

أيضا تم إلغاء أو عدم حساب ما هو فوق السنة الصحيحة بمعنى تم التقريب لأقرب رقم صحيح للأصغر بمعنى مثلا الموظف

اشتغل 10 سنوات ونص السنة سيتم فقط محاسبته على 10 سنوات

حتى لو عمل مثلا 15 سنة و11 شهر سيتم احتساب 15 سنة فقط بدون النظر إلى الشهور

مباشرة الاموال بالكامل.rar

مايو 30, 2015

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

جزاك الله خيرا

مايو 30, 2015

مشكوووووور والف الف شكر وربي يزيد علم كمان وكمان

سؤال

هل المعادلة السابقة يمكن توزيعها على الورقة رقم 1

لان في عملية الصرف يتم مراجعة خطوات الحساب

وعلية تتم الموافقة

واخي الكريم اريدك ان تلاحظ خانة سنوات الخدمة فيها كسور

اريدها ان تكون سنوات فقط دون شهور

ربنا يكرمك أخي والعفو

انت تقصد إنك تقسم المعادلة بحيث يحسب كل عدد سنوات على حدى زي ما انت عامل في الشيت الأول؟

وكمان بالنسبة للكسور متأكد انهم يحسبوا على السنوات بس؟

يعني لو موظف اشتغل 10 سنوات و 11 شهر مش هيتم إحتساب المكافاة على 11 شهر؟

لان الكسور هنا تمثل الشهور والأيام يعني مثلا 10.5 تعني عشر سنوات و 6 أشهر وهكذا

وأقدر الغيلك الكسور بس إنت اتأكد من الجزئية دي

مايو 30, 2015

السلام عليكم ورحمة الله

أخي الفاضل يفضل إرفاق نموذج مصغر للملف كما أشار أستاذ علاء

وأيضا كحل سريع على حسب فهمي

خلي الخلية اللي فيها المعادلة بتاعك Vlookup تنسيقها يكون Short Date

وتتحل المشكلة ان شاء الله

مايو 30, 2015

السلام عليكم

أتفضل أخي شوف الملف المرفق وبالنسبة للأكواد في الملف

الكود التالي في 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

مايو 30, 2015

السلام عليكم

مرحبا أخي

اتفضل شوف الملف المرفق

أنا عملت في الورقة 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

مايو 29, 2015

السلام عليكم أخي

انت تقصد تحسب مستحقات نهاية الخدمة ؟

أو مكافأة نهاية الخدمة زي ما تحب تسميها

اللي تكون مثلا نص شهر على أول 5 سنوات وشهر كامل على ما فوق الخمس سنوات وأقل من عشر سنوات وهكذا؟

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

مايو 29, 2015

السلام عليكم ورحمة الله وبركاته

مرحبا أخي الكريم

انا فهمت اللي إنت كاتبه في الملف بس المطلوب نفس مش واضح بالنسبة لي

أي لوت نمبر اللي انت عاوزه يظهر في المكان المخصص في حين ان لكل صنف أكتر من لوت نمبر واحد

وضحلي شوية لو أمكن

مايو 29, 2015

السلام عليكم وجمعة مباركة بإذن الله

اتفضل أخي انا ارفقت لك الملف وايضا جرب انك في المعادلات السابقة تستبدل الفاصلة بفاصلة منقوطة ( حرف ك والكيبورد بالإنجليزية) كالتالي

المعادلة الحالية

=DATEDIF(C11,G11,"y")

المعادلة الجديدة

=DATEDIF(C11;G11;"y")

مباشرة الاموال 2015.rar

مايو 28, 2015

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

مايو 28, 2015

السلام عليكم أخي

بعتذر فهمت غلط

طيب لو تقصد مثلا الفترة اللي اشتغلها الموظف من إلى لتكون كالتالي

10 سنة

5 شهور

25 يوم

تقدر تستخدم المعادلة التالية

لحساب السنة حيث C11 تاريخ بداية الفترة

G11 تاريخ نهاية الفترة

في خانة السنة ضع المعادلة التالية

=DATEDIF(C11,G11,"y")

خانة الشهر ضع المعادلة التالية

=DATEDIF(C11,G11,"ym")

خانة اليوم ضع المعادلة التالية

=DATEDIF(C11,G11,"yd")

وان شاء الله يكون هو ده المطلوب

مايو 28, 2015

السلام عليكم

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

مباشرة الاموال 2015.rar

مايو 28, 2015

أتمنى من الله أن تكونوا جميعا بالف خير

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

الموضوع هو عن فك حماية أوراق العمل 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

مايو 28, 2015

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

مايو 27, 2015

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

مايو 27, 2015

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

مايو 27, 2015

أتمنى من الله أن تكونوا جميعا بخير وصحة وسلامه وكل عام وأنتم بخير بمناسبة قرب الشهر المبارك واللهم بلغنا رمضان .

حبيت أقدم موضوع بسيط ومفيد في بعض الأحيان مع تطبيق تجدونه في المرفق

فكرة الموضوع: هي إن لو عندي يوزرفورم خاص بالإدخال أو التعديل أو الحذف أو البحث أو مهما كان طبيعة عمل اليوزرفورم أقدر إن من خلال الفورم الحالي

إني اعمل توليد لعدد لا نهائي من اليوزفورم وكل منهم يستخدم أيضا في الإدخال أو في أي من الأغراض التي من أجلها تم إنشاء اليوزر فورم الأساسي

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

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

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

إن شاء الله تكون فكرة مفيدة لكل اللي هيستخدمها ودمت في رعاية الله

Repeated Userform.rar

مايو 27, 2015

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

وربنا يزيدك من علمه وينفع بيك

مايو 27, 2015

اتفضل أخي في المرفق

تم حماية محرر الأكواد للملف بنفس الباسورد اللي انت كاتبه 123456

والطريقة انك بتفتح محرر الأكواد

وكليك يمين على اسم البروجيكت ثم تضغط VBAProject Properties

وتدخل على Protection

تضع علامه في Lock Project

وتكتب الباسورد وتكررها ومن ثم حفظ الملف

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

md.rar

مايو 27, 2015

السلام عليكم أخي

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

في انتظارك

مايو 26, 2015

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

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

مايو 26, 2015

السلام عليكم أخي

أنا عملتهالك بطريقة بدائية شوية

حطيت قصاد كل أرقام السيارات في العمود G القيمة 0

واستخدمت دالتي Vlookup و IFERROR

بحيث ان كل أرقام السيارات في العمود A سيتم البحث عن كل قيمة في هذا العمود هل هي موجودة في العمود G ولا لا

لو موجودة يجيب القيمة اللي قصادها وهي 0 اللي اضفناه في الخطوة السابقة

لو مش موجودة هيكتب القيمة من العمود B

والدالة المستخدمة كالتلي

=IFERROR(VLOOKUP(A3,$G$3:$H$8,2,FALSE),B3)

والمرفق يوضح أكثر ان شاء الله لحد ما يدخل الإخوة ويقدموا حلول أفضل بإذن الله

find.rar

مايو 26, 2015

السلام عليكم

مرحبا أخي

اتفضل شوف الملف المرفق لو مضبوط طلبك بطبقه على كل الأعمدة الموجودة

Classeur17.rar

مايو 26, 2015

السلام عليكم

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

وانتظر الأخوة برضو ان شاء الله يفيدوك أكتر

مايو 26, 2015

أتمنى من الله ان تكونوا في تمام الصحة والعافية

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

في المثال المرفق يوجد يوزر فورم وبه عدد 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

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه علي الشيخ

Important Information