mahmoud nasr alhasany

تفضل جرب هذا Employees Form-unprotected - Copy.xlsm

تفضل جرب هذا الحل باستخدام المعادلات مباشرة في الخلايا: يمكنك وضع المعادلات التالية مباشرة في الخلايا المطلوبة في ورقة "Sheet10": الخلية C3: =G4 الخلية E3: =IF(EOMONTH(C3,6)>G5,G5,EOMONTH(C3,6)) الخلية C4: =E3+1 الخلية E4: =IF(EOMONTH(C4,6)>G5,G5,EOMONTH(C4,6)) الخلية C5: =E4+1 الخلية E5: =IF(EOMONTH(C5,6)>G5,G5,EOMONTH(C5,6)) الخلية C6: =E5+1 الخلية E6: =IF(EOMONTH(C6,6)>G5,G5,EOMONTH(C6,6)) الخلية C7: =E6+1 الخلية E7: =IF(EOMONTH(C7,6)>G5,G5,EOMONTH(C7,6)) الخلية C8: =E7+1 الخلية E8: =IF(EOMONTH(C8,6)>G5,G5,EOMONTH(C8,6)) الخلية C9: =E8+1 الخلية E9: =IF(EOMONTH(C9,6)>G5,G5,EOMONTH(C9,6)) الخلية C10: =E9+1 الخلية E10: =IF(EOMONTH(C10,6)>G5,G5,EOMONTH(C10,6)) شرح المعادلات: EOMONTH(date, months): تقوم هذه الدالة بإرجاع تاريخ نهاية الشهر الذي يقع قبل أو بعد عدد محدد من الأشهر من تاريخ البداية. في حالتنا، نضيف 6 أشهر إلى التاريخ الموجود في العمود C للحصول على نهاية شهر يونيو التالي. IF(logical_test, value_if_true, value_if_false): تقوم هذه الدالة بفحص شرط معين. إذا كان الشرط صحيحًا، فإنها ترجع القيمة الأولى؛ وإلا فإنها ترجع القيمة الثانية. في حالتنا، نتحقق مما إذا كان تاريخ نهاية يونيو أكبر من القيمة الموجودة في الخلية G5. إذا كان أكبر، نكتب قيمة G5؛ وإلا، نكتب تاريخ نهاية يونيو. ملاحظات: تأكد من أن ورقة العمل التي تريد تطبيق الكود أو المعادلات عليها اسمها "Sheet10" بالضبط. إذا كان اسمها مختلفًا، فقم بتعديل اسم الورقة في كود VBA أو عند الإشارة إلى الخلايا في المعادلات. في كود VBA، يتم تنفيذ كل سطر برمجي بشكل منفصل كما طلبت. باستخدام المعادلات، ستتحدث الخلايا تلقائيًا عند تغيير القيم في الخلايا التي تعتمد عليها (مثل G4 أو الخلايا في العمود C). اختر الطريقة التي تناسب احتياجاتك بشكل أفضل. إذا كنت بحاجة إلى تشغيل هذه العمليات بشكل متكرر أو كجزء من عملية أكبر، فقد يكون كود VBA أكثر ملاءمة. أما إذا كانت العملية تتم مرة واحدة أو كنت تفضل عدم استخدام وحدات الماكرو، فإن استخدام المعادلات مباشرة في الخلايا هو خيار جيد. Sub FillCells() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة 10") ' تعيين قيمة الخلية C3 ws.Range("C3").Value = ws.Range("G4").Value ' تعيين معادلة الخلية E3 ws.Range("E3").Formula = "=IF(EOMONTH(C3,6)>G5,G5,EOMONTH(C3,6))" ' تعيين قيمة الخلية C4 ws.Range("C4").Value = ws.Range("E3").Value + 1 ' تعيين معادلة الخلية E4 ws.Range("E4").Formula = "=IF(EOMONTH(C4,6)>G5,G5,EOMONTH(C4,6))" ' تعيين قيمة الخلية C5 ws.Range("C5").Value = ws.Range("E4").Value + 1 ' تعيين معادلة الخلية E5 ws.Range("E5").Formula = "=IF(EOMONTH(C5,6)>G5,G5,EOMONTH(C5,6))" ' تعيين قيمة الخلية C6 ws.Range("C6").Value = ws.Range("E5").Value + 1 ' تعيين معادلة الخلية E6 ws.Range("E6").Formula = "=IF(EOMONTH(C6,6)>G5,G5,EOMONTH(C6,6))" ' تعيين قيمة الخلية C7 ws.Range("C7").Value = ws.Range("E6").Value + 1 ' تعيين معادلة الخلية E7 ws.Range("E7").Formula = "=IF(EOMONTH(C7,6)>G5,G5,EOMONTH(C7,6))" ' تعيين قيمة الخلية C8 ws.Range("C8").Value = ws.Range("E7").Value + 1 ' تعيين معادلة الخلية E8 ws.Range("E8").Formula = "=IF(EOMONTH(C8,6)>G5,G5,EOMONTH(C8,6))" ' تعيين قيمة الخلية C9 ws.Range("C9").Value = ws.Range("E8").Value + 1 ' تعيين معادلة الخلية E9 ws.Range("E9").Formula = "=IF(EOMONTH(C9,6)>G5,G5,EOMONTH(C9,6))" ' تعيين قيمة الخلية C10 ws.Range("C10").Value = ws.Range("E9").Value + 1 ' تعيين معادلة الخلية E10 ws.Range("E10").Formula = "=IF(EOMONTH(C10,6)>G5,G5,EOMONTH(C10,6))" End Sub المصنف (155).xlsm

تفضل جرب هذا ورجاء ادخال مسارات الصورة فى العمود 10 فى شيت DbSheet او من خلال تحديد الاسم فى السجل داخل الليست بوكس وادخال الصورة المدرجة الخاصة بالموظف منظومة-الشؤون-الادارية - Copy - Copy.xlsm

بعد اذن استاذنا المتألق دائما / محمد هشام. تم اضافة المسلسل تلقائى وتم تسجيل تاريخ ووقت التعديل واسم المستخدم تلقائيًا عند تعديل أي سجل في جدول البيانات الخاص بك. فى العمود 8 والعمود 9 منظومة-الشؤون-الادارية - Copy.xlsm

تفضل جرب هذا الحدث Sub CreateNextMonthSheetAndLockOfficialHolidays() ' تسريع الكود Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False Dim ws As Worksheet, copiedSheet As Worksheet, monthTable As Worksheet, dataSheet As Worksheet Dim currentMonth As String, nextMonth As String, nextMonthArabic As String Dim i As Integer, foundRow As Range Dim dateCell As Range, checkDate As Date Dim holidayRange As Range, holidayCell As Cell Dim col As Range Dim isHoliday As Boolean Dim colNum As Long Dim weekdayNum As Integer Dim lockedText As String ' إعداد الشيتات Set ws = ActiveSheet Set monthTable = ThisWorkbook.Sheets("MonthNames") Set dataSheet = ThisWorkbook.Sheets("data") currentMonth = ws.Name ' جلب النص من MonthNames!H1 lockedText = monthTable.Range("H1").Value ' البحث عن اسم الشهر الحالي Set foundRow = monthTable.Range("A1:A12").Find(What:=currentMonth, LookIn:=xlValues, LookAt:=xlWhole) If foundRow Is Nothing Then MsgBox "Current sheet name '" & currentMonth & "' not found in MonthNames sheet.", vbCritical GoTo Cleanup End If ' تحديد الشهر التالي If foundRow.Row = 12 Then nextMonth = monthTable.Range("A1").Value nextMonthArabic = monthTable.Range("B1").Value Else nextMonth = monthTable.Cells(foundRow.Row + 1, 1).Value nextMonthArabic = monthTable.Cells(foundRow.Row + 1, 2).Value End If ' التأكد أن الشيت غير موجود مسبقًا For i = 1 To ThisWorkbook.Sheets.Count If ThisWorkbook.Sheets(i).Name = nextMonth Then MsgBox "Sheet '" & nextMonth & "' already exists.", vbExclamation GoTo Cleanup End If Next i ' نسخ الشيت الحالي ws.Copy After:=ws Set copiedSheet = ActiveSheet On Error Resume Next copiedSheet.Name = nextMonth If Err.Number <> 0 Then MsgBox "Error renaming the new sheet.", vbCritical GoTo Cleanup End If On Error GoTo 0 ' تفريغ البيانات copiedSheet.Range("F11:AJ500").ClearContents ' تحديث D5 copiedSheet.Range("D5").Value = nextMonthArabic ' فك الحماية copiedSheet.Unprotect Password:="1234" copiedSheet.Range("F11:AJ130").Locked = False ' قراءة العطلات من الشيت "data" Set holidayRange = dataSheet.Range("F5:F25") ' المرور على الأعمدة من F إلى AJ (أرقام الأعمدة 6 إلى 36) For colNum = 6 To 36 Set dateCell = copiedSheet.Cells(10, colNum) Set col = copiedSheet.Range(copiedSheet.Cells(11, colNum), copiedSheet.Cells(130, colNum)) isHoliday = False If IsDate(dateCell.Value) Then checkDate = CDate(dateCell.Value) ' استخدام Weekday مع vbSaturday: السبت = 1، الجمعة = 7 weekdayNum = Weekday(checkDate, vbSaturday) ' التحقق من العطلات الرسمية For Each holidayCell In holidayRange If IsDate(holidayCell.Value) Then If Int(CDate(holidayCell.Value)) = Int(checkDate) Then isHoliday = True Exit For End If End If Next holidayCell ' إذا الجمعة (7) أو السبت (1) أو عطلة If weekdayNum = 1 Or weekdayNum = 7 Or isHoliday Then ' كتابة النص في الخلايا الفارغة وقفل العمود وحذف القائمة المنسدلة Dim r As Range For Each r In col If Trim(r.Value) = "" Then r.Value = lockedText End If r.Locked = True Next r On Error Resume Next col.Validation.Delete On Error GoTo 0 Else ' السماح بالكتابة في الأيام الأخرى col.Locked = False End If End If Next colNum ' إعادة الحماية copiedSheet.Protect Password:="1234", UserInterfaceOnly:=True ' تفعيل الشيت الجديد copiedSheet.Activate MsgBox "✅ Sheet '" & nextMonth & "' has been created successfully." & vbCrLf & _ "✔ Fridays, Saturdays, and official holidays are now locked, and the text '" & lockedText & "' has been added." & vbCrLf & _ "✔ Dropdown lists have been removed from locked days.", vbInformation Cleanup: ' إعادة الإعدادات لطبيعتها Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True End Sub

تفضل المطلوب ولو اردت استخدام دالة IF لإضافة شروط إضافية، مثل عرض "كيلو" فقط إذا كانت الجرامات صفرًا. هذه المعادلة فى السطر 56 =IF(MOD(SUM(E3:E53);1000)=0;INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو";INT(SUM(E3:E53)/1000)+SUM(F3:F53)&" كيلو و "&TEXT(MOD(SUM(E3:E53);1000);"0")&" جرام") شغل.xlsx

جرب هذه المعادلة شرح المعادلة ROUND(L4/280*100,1): تقوم هذه الدالة بحساب النسبة المئوية وتقريبها إلى خانة عشرية واحدة. INT(ROUND(L4/280*100,1)): تقوم هذه الدالة بإرجاع الجزء الصحيح من الرقم المقرب. IF(ROUND(L4/280*100,1)=INT(ROUND(L4/280*100,1)),...,...): تقوم هذه الدالة بالتحقق مما إذا كان الرقم المقرب مساويًا للجزء الصحيح منه. إذا كان مساويًا، فهذا يعني أن الرقم صحيح، وإلا فهو عشري. TEXT(ROUND(L4/280*100,1),"0"): إذا كان الرقم صحيحًا، تقوم هذه الدالة بتحويله إلى نص بدون أصفار عشرية. TEXT(ROUND(L4/280*100,1),"0.0"): إذا كان الرقم عشريًا، تقوم هذه الدالة بتحويله إلى نص بخانة عشرية واحدة. مثال إذا كانت L4 تحتوي على 140، فإن الناتج سيكون 50. إذا كانت L4 تحتوي على 141، فإن الناتج سيكون 50.4. آمل أن تكون هذه المعادلة المعدلة تحقق المطلوب. =IF(ROUND(L3/280*100;1)=INT(ROUND(L3/280*100;1));TEXT(ROUND(L3/280*100;1);"0");TEXT(ROUND(L3/280*100;1);"0.0"))

احسنت ا / محمد هشام

وهذا كود معدل لجعل النطاقات في areas تعتمد على LastRow لتكون ديناميكية وتتغير تلقائيًا مع عدد الصفوف في ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim areas As Range Dim lastRow As Long ' تحديد آخر صف يحتوي على بيانات في العمود C (أو أي عمود آخر يحتوي على بيانات) lastRow = Me.Cells(Me.Rows.Count, "C").End(xlUp).Row ' إعداد النطاقات المتعددة باستخدام LastRow Set areas = Union(Me.Range("C10:L" & lastRow), Me.Range("S10:S" & lastRow), Me.Range("V10:V" & lastRow)) ' التعامل مع تغيير الخلايا On Error GoTo ClearApp Application.EnableEvents = False ' منع اللصق إلا كقيم Set rng = Intersect(Target, areas) If Not rng Is Nothing Then Application.Undo ' التراجع عن اللصق الأصلي For Each cell In rng cell.Value = Target.Value ' لصق القيمة فقط Next cell End If ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub

وهذا الكود الى اخر بيانات مدرجه وليس نطاق معين .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo Sub ترتيب_وعرض_أرصدة_العملاء() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDebt As Double Set ws = ThisWorkbook.Sheets("ورقة1") With ws ' 1. تحديد LastRow lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row ' 2. ترتيب البيانات تنازليًا حسب رصيد العميل باستخدام LastRow .Range("A6:AH" & lastRow).Sort Key1:=.Range("L6:L" & lastRow), Order1:=xlDescending, Header:=xlNo ' 3. إخفاء الصفوف التي تحتوي على أرصدة غير موجبة أو تساوي صفرًا For i = 6 To lastRow If .Cells(i, "L").Value <= 0 Then .Rows(i).Hidden = True Else .Rows(i).Hidden = False End If Next i ' 4. حساب إجمالي المديونية باستخدام LastRow totalDebt = WorksheetFunction.SumIf(.Range("L6:L" & lastRow), ">0") ' 5. عرض إجمالي المديونية وتنسيقها .Range("AH1").Value = totalDebt .Range("AH1").NumberFormat = "#,##0.00 ""ج.م""" ' تنسيق مخصص ' 6. تنسيق الخلية AI1 With .Range("AI1") .Font.Color = RGB(255, 0, 0) .Font.Bold = True .Value = "إجمالي المديونية: " & totalDebt End With End With End Sub

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Dim areas As Range Dim cell As Range ' إعداد النطاقات المتعددة Set areas = Union(Me.Range("C10:L109"), Me.Range("S10:S109"), Me.Range("V10:V109")) ' التعامل مع تغيير الخلايا On Error GoTo ClearApp Application.EnableEvents = False ' منع اللصق إلا كقيم Set rng = Intersect(Target, areas) If Not rng Is Nothing Then Application.Undo ' التراجع عن اللصق الأصلي For Each cell In rng cell.Value = Target.Value ' لصق القيمة فقط Next cell End If ExitHandler: Application.EnableEvents = True Exit Sub ClearApp: Resume ExitHandler End Sub

رتيب البيانات: تمت إضافة lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row لتحديد آخر صف يحتوي على بيانات في العمود L (رصيد العميل). هذا يضمن أن الحلقة التالية تغطي جميع البيانات. إخفاء الصفوف: تمت إضافة حلقة For للتكرار على جميع الصفوف من 6 إلى lastRow. داخل الحلقة، يتم التحقق من قيمة رصيد العميل في العمود L. إذا كان الرصيد غير موجب (أقل من أو يساوي صفرًا)، يتم إخفاء الصف باستخدام .Rows(i).Hidden = True. إذا كان الرصيد موجبًا، يتم إظهار الصف باستخدام .Rows(i).Hidden = False (للتأكد من إظهار الصفوف التي قد تكون مخفية سابقًا). حساب إجمالي المديونية: تم استخدام الدالة WorksheetFunction.SumIf لحساب مجموع الأرصدة الموجبة فقط في النطاق L6:L75. تم تخزين النتيجة في المتغير totalDebt. عرض إجمالي المديونية: تمت إضافة السطر .Range("AI1").Value = "إجمالي المديونية: " تمت إضافة السطر . & totalDebt لعرض إجمالي المديونية في الخلية AH1. بللون الاحمر خط عريض وتنسيق القيمة بالجنية المصرى يمكنك تغيير الخلية حسب الحاجة. Sub ترتيب_وعرض_أرصدة_العملاء() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDebt As Double Set ws = ThisWorkbook.Sheets("ورقة1") With ws ' 1. ترتيب البيانات تنازليًا حسب رصيد العميل .Range("A6:AH75").Sort Key1:=.Range("L6:L75"), Order1:=xlDescending, Header:=xlNo ' 2. إخفاء الصفوف التي تحتوي على أرصدة غير موجبة أو تساوي صفرًا lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row For i = 6 To lastRow If .Cells(i, "L").Value <= 0 Then .Rows(i).Hidden = True Else .Rows(i).Hidden = False End If Next i ' 3. حساب إجمالي المديونية totalDebt = WorksheetFunction.SumIf(.Range("L6:L75"), ">0") ' 4. عرض إجمالي المديونية .Range("AI1").Value = "إجمالي المديونية: " .Range("AH1").Value = totalDebt .Range("AH1").NumberFormat = "#,##0.00 ""ج.م""" ' تنسيق مخصص ' 5. تنسيق الخلية AH1 With .Range("AH1") .Font.Color = RGB(255, 0, 0) ' تعيين لون الخط إلى الأحمر .Font.Bold = True ' تعيين الخط إلى عريض End With End With End Sub مديونية 2025م(1).xls

ماذالت المشكلة قائمة فى عرض التقارير والخصومات حضور وانصراف 1.xlsm

مشكلة فى عرض تقرير حضور وانصراف بصيغة word/pdf حضور وانصراف 1.xlsm

جرب احدى البرنامجين ده بس حاول تعمل ايميل على اوتلوك برنامج SEND EMAIL.xlsb Send Email (VBA) - Copy.xlsm

جرب هذا الكود تحليل الكود: يقوم الكود بحساب مدة الالتزامات بناءً على شهور البداية والنهاية الموجودة في ورقة عمل Excel، ثم يحسب المدة الإجمالية والمتبقية. الخطوات: تحديد ورقة العمل: يتم تحديد ورقة العمل المسماة "Sheet1" (يمكنك تغييرها حسب الحاجة). حساب مدد الالتزامات: يتم المرور على كل صف في العمود "A" (بدءًا من الصف الثاني). يتم استخراج شهور البداية والنهاية من العمودين "D" و "F" على التوالي. يتم حساب المدة لكل التزام (شهر النهاية - شهر البداية + 1) وتخزينها في العمود "H". يتم حساب المدة الإجمالية لكل الالتزامات. حساب المدة المتبقية: يتم حساب المدة المتبقية بطرح المدة الإجمالية من 240. كتابة النتائج: يتم كتابة المدة الإجمالية والمدة المتبقية في الصفوف التالية لآخر صف مستخدم في العمود "A". رسالة تأكيد: يتم عرض رسالة تأكيد للمستخدم. Sub RoundedRectangle6_Click() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim totalDuration As Long Dim remainingDuration As Long Dim startMonth As Long Dim endMonth As Long ' تحديد ورقة العمل Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك ' حساب مدد الالتزامات lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow startMonth = Val(ws.Cells(i, "D").Value) endMonth = Val(ws.Cells(i, "F").Value) ws.Cells(i, "H").Value = endMonth - startMonth + 1 totalDuration = totalDuration + ws.Cells(i, "H").Value Next i ' حساب المدة المتبقية remainingDuration = 240 - totalDuration ' كتابة المدة الإجمالية والمدة المتبقية ws.Cells(lastRow + 2, "A").Value = "المدة الإجمالية:" ws.Cells(lastRow + 2, "B").Value = totalDuration ws.Cells(lastRow + 3, "A").Value = "المدة المتبقية:" ws.Cells(lastRow + 3, "B").Value = remainingDuration ' رسالة تأكيد MsgBox "تم إنشاء الجدول وحساب المدد." End Sub

نعم، أنت محق .ahrambakr بما أن الملف معى يعمل بشكل صحيح ، فالمشكلة بالتأكيد تتعلق بإعدادات نظام التشغيل أو Excel لديك. إليك بعض الخطوات التي يمكنك اتخاذها لحل المشكلة: 1. التحقق من إعدادات اللغة في نظام التشغيل: منطقة اللغة: تأكد من أن "المنطقة" في إعدادات Windows مضبوطة على بلد يستخدم اللغة العربية كلغة أساسية. اذهب إلى "إعدادات" -> "الوقت واللغة" -> "المنطقة". اللغات: تأكد من إضافة اللغة العربية إلى قائمة اللغات المفضلة. اذهب إلى "إعدادات" -> "الوقت واللغة" -> "اللغة". 2. التحقق من إعدادات اللغة في Excel: خيارات اللغة: افتح Excel واذهب إلى "ملف" -> "خيارات" -> "اللغة". تأكد من أن اللغة العربية هي اللغة الافتراضية للعرض والتحرير. خيارات متقدمة: في "خيارات" -> "متقدم"، تحقق من إعدادات "عرض" و"تحرير" المتعلقة باللغات. 3. التحقق من خطوط الكتابة: تنسيق الخلايا: حدد الخلايا التي تحتوي على النص الذي يظهر بشكل غير صحيح. انقر بزر الماوس الأيمن واختر "تنسيق الخلايا". في علامة التبويب "خط"، تأكد من اختيار خط يدعم اللغة العربية بشكل كامل (مثل Arial أو Times New Roman). 4. إعادة تشغيل الجهاز: في بعض الأحيان، قد تتطلب تغييرات إعدادات اللغة إعادة تشغيل الجهاز لتطبيقها بشكل كامل. 5. تحديث Excel: تأكد من أن لديك أحدث إصدار من Excel مثبتًا. قد تحتوي التحديثات على إصلاحات لمشاكل توافق اللغة. 6. تجربة على جهاز آخر: إذا استمرت المشكلة، حاول فتح الملف على جهاز آخر بإعدادات لغة مختلفة لمعرفة ما إذا كانت المشكلة خاصة بجهازك. ملاحظات إضافية: قد يكون هناك تعارض بين بعض إعدادات اللغة في Windows و Excel. قد تكون هناك بعض الملفات المؤقتة التالفة التي تسبب هذه المشكلة. إذا كنت تستخدم إصدارًا قديمًا جدًا من Excel، فقد تواجه مشاكل في توافق اللغة. آمل أن تساعدك هذه الخطوات في حل المشكلة.ahrambakr

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

هذا الكود لتحويل الأرقام إلى كلمات في العمود B عند إدخال قيمة في العمود A، مع مراعاة اللغة العربية والعملة (الجنيه المصري). شرح الكود: Worksheet_Change: هذا الإجراء يتم تشغيله تلقائيًا عند تغيير أي خلية في ورقة العمل. Tafqit: هذه الدالة الرئيسية تقوم بتحويل الرقم إلى نص، مع مراعاة الجزء الصحيح والجزء العشري. TafqitInteger: هذه الدالة تقوم بتحويل الجزء الصحيح من الرقم إلى نص. TafqitGroup: هذه الدالة تقوم بتحويل مجموعة من ثلاثة أرقام إلى نص (مئات، آلاف، ملايين). ملاحظات هامة: هذا الكود يدعم الأرقام الصحيحة والأرقام العشرية. تمت إضافة دعم للغة العربية والعملة (الجنيه المصري). يمكنك تعديل الكود لتغيير العملة أو لإضافة دعم لعملات أخرى. الكود يعمل علي القيم الموجبة فقط. يمكن إضافة بعض التعديلات علي الكود لتحسينه. آمل أن يكون هذا الكود مفيدًا! Private Sub Worksheet_Change(ByVal Target As Range) Dim cell As Range 'تحديد العمود الذي سيتم مراقبته (العمود A) If Not Intersect(Target, Columns("A")) Is Nothing Then 'المرور على الخلايا التي تم تغييرها For Each cell In Target 'التحقق من أن الخلية تحتوي على قيمة رقمية If IsNumeric(cell.Value) Then 'استدعاء دالة التفقيط ووضع النتيجة في العمود B cell.Offset(0, 1).Value = Tafqit(cell.Value) End If Next cell End If End Sub Function Tafqit(ByVal num As Double) As String Dim strNum As String Dim parts As Variant Dim intPart As Long Dim decPart As Long Dim result As String 'فصل الجزء الصحيح والجزء العشري strNum = Format(num, "0.00") parts = Split(strNum, ".") intPart = CLng(parts(0)) decPart = CLng(parts(1)) 'تفقيط الجزء الصحيح result = TafqitInteger(intPart) 'إضافة كلمة "جنيه" If intPart > 0 Then result = result & " جنيه" End If 'تفقيط الجزء العشري If decPart > 0 Then result = result & " و " & TafqitInteger(decPart) & " قرش" End If Tafqit = result End Function Function TafqitInteger(ByVal num As Long) As String Dim units As Variant, tens As Variant, hundreds As Variant Dim groups(2) As Long Dim result As String Dim i As Integer units = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") hundreds = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") groups(0) = num Mod 1000 groups(1) = (num \ 1000) Mod 1000 groups(2) = num \ 1000000 For i = 2 To 0 Step -1 If groups(i) > 0 Then result = result & " " & TafqitGroup(groups(i), i) End If Next i TafqitInteger = Trim(result) End Function Function TafqitGroup(ByVal num As Long, ByVal groupIndex As Integer) As String Dim units As Variant, tens As Variant, hundreds As Variant Dim result As String units = Array("", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة", "عشرة", "أحد عشر", "اثنا عشر", "ثلاثة عشر", "أربعة عشر", "خمسة عشر", "ستة عشر", "سبعة عشر", "ثمانية عشر", "تسعة عشر") tens = Array("", "عشرة", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون") hundreds = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة") If num >= 100 Then result = result & hundreds(num \ 100) & " " num = num Mod 100 End If If num >= 20 Then result = result & tens(num \ 10) & " " & units(num Mod 10) ElseIf num >= 10 Then result = result & units(num) Else result = result & units(num) End If Select Case groupIndex Case 1 If num > 0 Then result = result & " ألف" Case 2 If num > 0 Then result = result & " مليون" End Select TafqitGroup = Trim(result) End Function صيغة تفقيط.xlsm

المشكلة التي تواجهك في VBA Excel عند تحويل الأرقام إلى كلمات وظهور علامات استفهام أو حروف غير مفهومة، هي مشكلة شائعة تتعلق بترميز الأحرف (Encoding) في VBA. إليك شرح للمشكلة وحلولها: سبب المشكلة: ترميز الأحرف: VBA يستخدم ترميزًا معينًا للأحرف، وأحيانًا لا يتوافق هذا الترميز مع الترميز المستخدم في النص الذي تحاول تحويله. عندما يكون هناك عدم توافق في الترميز، تظهر الأحرف بشكل غير صحيح، مثل علامات الاستفهام أو الرموز الغريبة. إعدادات اللغة: إعدادات اللغة في نظام التشغيل وفي Excel يمكن أن تؤثر على كيفية عرض الأحرف. إذا كانت إعدادات اللغة غير متوافقة، فقد تظهر الأحرف بشكل غير صحيح. حلول المشكلة: استخدام ترميز UTF-8: UTF-8 هو ترميز عالمي يدعم معظم اللغات، بما في ذلك اللغة العربية. يمكنك محاولة تحويل النص إلى ترميز UTF-8 قبل عرضه في Excel. هذا الحل يحتاج الي تعديل الكود المسئول عن تحويل الارقام الي نص. تغيير إعدادات اللغة في Excel: تأكد من أن إعدادات اللغة في Excel متوافقة مع اللغة العربية. يمكنك التحقق من ذلك من خلال: ملف > خيارات > اللغة. تأكد من أن اللغة العربية هي اللغة الافتراضية. تغيير إعدادات اللغة في نظام التشغيل: تأكد من أن إعدادات اللغة في نظام التشغيل متوافقة مع اللغة العربية. يمكنك التحقق من ذلك من خلال: لوحة التحكم > المنطقة واللغة. استخدام دوال تحويل الأرقام إلى كلمات جاهزة: هناك بعض الدوال الجاهزة التي يمكن استخدامها لتحويل الأرقام إلى كلمات باللغة العربية. قد تكون هذه الدوال أكثر موثوقية من الدوال المخصصة التي قد تواجه مشاكل في الترميز. يوجد الكثير من الاكواد الجاهزة علي الانترنت التي تقوم بنفس الغرض. التأكد من خطوط الكتابة: بعض الخطوط لا تدعم اللغة العربية بشكل كامل, لذلك يجب التأكد من الخط المستخدم داخل ملف الاكسل يدعم اللغة العربية. نصائح إضافية: إذا كنت تستخدم دالة مخصصة لتحويل الأرقام إلى كلمات، فحاول البحث عن تحديثات أو إصلاحات لهذه الدالة. إذا كنت تستخدم دالة خارجية، فتأكد من أنها متوافقة مع إصدار Excel الذي تستخدمه. تاكد من حفظ ملف الاكسل بصيغة تدعم اللغة العربية بشكل كامل. آمل أن تساعدك هذه الحلول في حل المشكلة الرجاء ان ترفق الملف اذا لم تنجح معك الحلول السابقة للمساعدتك

تفضل ورقة ارسال عن طريق الواتس اسهل طريقة ارسال وربط ملف الاكسيل بالواتس اب وارسال رسائل المدرسة او الشركة من الاكسيل للواتس اب.xlsm

Sub StringSort() Dim WS As Worksheet Dim lastRow As Long Dim sortRange As Range ' اسم ورقة العمل (يمكن تغييره) Const SHEET_NAME As String = "Sheet1" Application.ScreenUpdating = False ' التحقق من وجود ورقة العمل On Error Resume Next Set WS = ThisWorkbook.Sheets(SHEET_NAME) On Error GoTo 0 If WS Is Nothing Then MsgBox "ورقة العمل '" & SHEET_NAME & "' غير موجودة.", vbExclamation GoTo Cleanup End If ' العثور على الصف الأخير في العمود A lastRow = WS.Range("A" & WS.Rows.Count).End(xlUp).Row ' التحقق من وجود بيانات If lastRow < 2 Then MsgBox "لا توجد بيانات للفرز.", vbExclamation GoTo Cleanup End If ' تحديد نطاق الفرز Set sortRange = WS.Range("A1:E" & lastRow) With WS.Sort .SortFields.Clear With .SortFields .Add Key:=WS.Range("C2:C" & lastRow), Order:=xlDescending .Add Key:=WS.Range("D2:D" & lastRow), Order:=xlAscending .Add Key:=WS.Range("E2:E" & lastRow), Order:=xlAscending End With .SetRange sortRange .Header = xlYes .Apply End With Cleanup: Application.ScreenUpdating = True End Sub

إليك كود VBA في Excel لتحقيق ذلك، مع شرح تفصيلي: شرح الكود المتغيرات: lastRow: لتحديد آخر صف يحتوي على بيانات في العمود A (يمكنك تغيير العمود حسب الحاجة). i: متغير يستخدم في حلقة التكرار للمرور على الصفوف. endDate: لتخزين تاريخ انتهاء العقد. daysRemaining: لحساب عدد الأيام المتبقية حتى انتهاء العقد. emailAddress: لتخزين عنوان البريد الإلكتروني للشخص المعني. messageBody: لتخزين نص الرسالة. حلقة التكرار: تكرر الحلقة على جميع الصفوف التي تحتوي على بيانات. تفترض أن تاريخ انتهاء العقد موجود في العمود B، وأن عنوان البريد الإلكتروني موجود في العمود C، ونص الرسالة موجود في العمود D. يمكنك تغيير هذه الأعمدة حسب الحاجة. يتم حساب عدد الأيام المتبقية حتى انتهاء العقد باستخدام الدالة DateDiff. إذا كان عدد الأيام المتبقية 60 يومًا أو أقل، يتم تنفيذ الخطوات التالية: جلب عنوان البريد الإلكتروني ونص الرسالة. استخدام CreateObject("Outlook.Application") لإرسال البريد الإلكتروني. تحديد عنوان المرسل إليه، الموضوع، ونص الرسالة. عرض البريد الإلكتروني أو إرساله مباشرةً. إرسال واتساب: تتطلب هذه الخطوة استخدام واجهة برمجة تطبيقات (API) خاصة بـ WhatsApp، حيث لا يوجد طريقة مباشرة لإرسال رسائل WhatsApp باستخدام VBA فقط. يمكنك استخدام خدمات مثل Twilio أو MessageBird أو غيرها لإرسال رسائل WhatsApp عبر API. يجب عليك التسجيل في إحدى هذه الخدمات والحصول على مفتاح API. يمكنك استخدام الدالة CreateObject("MSXML2.XMLHTTP") لإرسال طلب HTTP إلى API الخاص بـ WhatsApp. الكود ملاحظات: تأكد من تغيير أسماء الأعمدة في الكود لتتوافق مع بياناتك. لتفعيل إرسال الايميل يجب تفعيل المكتبة الخاصة ب outlook من قائمة tools ثم references ثم اختيار Microsoft outlook Object Library. لإرسال رسائل WhatsApp، ستحتاج إلى إضافة كود إضافي باستخدام API. يمكنك تخصيص نص الرسالة وموضوع البريد الإلكتروني حسب الحاجة. يمكنك جدولة تشغيل هذا الكود تلقائيًا باستخدام وظيفة "جدولة المهام" في Windows. إضافة كود لإرسال رسائل WhatsApp باستخدام API يتطلب بعض الخطوات الإضافية. إليك شرح لكيفية القيام بذلك باستخدام خدمة Twilio، وهي واحدة من الخدمات الشائعة التي توفر واجهة برمجة تطبيقات (API) لإرسال رسائل WhatsApp: 1. التسجيل في Twilio والحصول على مفتاح API: قم بزيارة موقع Twilio وقم بإنشاء حساب. بعد تسجيل الدخول، انتقل إلى وحدة تحكم Twilio واحصل على مفتاح API الخاص بك (Account SID وAuth Token). قم بتمكين WhatsApp في حساب Twilio الخاص بك. احصل على رقم هاتف Twilio يدعم WhatsApp. 2. إضافة مكتبة MSXML2: في محرر VBA، انتقل إلى "Tools" ثم "References". ابحث عن "Microsoft XML, v6.0" أو إصدار أحدث وقم بتحديده. 3. كود VBA لإرسال رسالة WhatsApp: Sub SendEmailOrWhatsApp() Dim lastRow As Long Dim i As Long Dim endDate As Date Dim daysRemaining As Long Dim emailAddress As String Dim messageBody As String lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A For i = 2 To lastRow ' ابدأ من الصف الثاني (بافتراض أن الصف الأول هو رأس الجدول) endDate = Cells(i, "B").Value ' تاريخ انتهاء العقد في العمود B daysRemaining = DateDiff("d", Date, endDate) ' حساب الأيام المتبقية emailAddress = Cells(i, "C").Value ' عنوان البريد الإلكتروني في العمود C messageBody = Cells(i, "D").Value ' نص الرسالة في العمود D If daysRemaining <= 60 Then ' إرسال بريد إلكتروني Dim outlookApp As Object Dim outlookMail As Object Set outlookApp = CreateObject("Outlook.Application") Set outlookMail = outlookApp.CreateItem(0) With outlookMail .To = emailAddress .Subject = "تنبيه: انتهاء العقد" .Body = messageBody .Display ' أو .Send للإرسال مباشرةً End With Set outlookMail = Nothing Set outlookApp = Nothing ' إرسال واتساب (يتطلب استخدام API) ' يمكنك إضافة كود لإرسال واتساب هنا باستخدام API End If Next i End Sub Sub SendWhatsAppMessage(phoneNumber As String, messageBody As String) Dim xmlHttp As Object Dim accountSid As String Dim authToken As String Dim twilioNumber As String Dim url As String accountSid = "ACxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' استبدل بـ Account SID الخاص بك authToken = "your_auth_token" ' استبدل بـ Auth Token الخاص بك twilioNumber = "whatsapp:+1xxxxxxxxxx" ' استبدل برقم Twilio الخاص بك phoneNumber = "whatsapp:+xxxxxxxxxxx" ' استبدل برقم هاتف المستلم url = "https://api.twilio.com/2010-04-01/Accounts/" & accountSid & "/Messages.json" Set xmlHttp = CreateObject("MSXML2.XMLHTTP") xmlHttp.Open "POST", url, False xmlHttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(accountSid & ":" & authToken) xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" xmlHttp.send "To=" & phoneNumber & "&From=" & twilioNumber & "&Body=" & EncodeUrl(messageBody) If xmlHttp.Status = 201 Then MsgBox "تم إرسال رسالة WhatsApp بنجاح!" Else MsgBox "فشل إرسال رسالة WhatsApp. الحالة: " & xmlHttp.Status End If Set xmlHttp = Nothing End Sub Function EncodeBase64(text As String) As String Dim arrData() As Byte arrData = StrConv(text, vbFromUnicode) Dim objXML As Object Dim objNode As Object Set objXML = CreateObject("MSXML2.DOMDocument") Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = arrData EncodeBase64 = objNode.text Set objNode = Nothing Set objXML = Nothing End Function Function EncodeUrl(text As String) As String Dim objXML As Object Set objXML = CreateObject("MSXML2.DOMDocument") EncodeUrl = objXML.createElement("url").appendChild(objXML.createTextNode(text)).ParentNode.innerHTML Set objXML = Nothing End Function

تم عمل استعلام موظف Sub بحث_في_السجل() Dim wsSijel As Worksheet, wsBataka As Worksheet Dim startDate As Date, endDate As Date Dim employeeName As String, movementType As String Dim i As Long, j As Long Dim lastRowSijel As Long, lastRowBataka As Long 'تعيين أوراق العمل Set wsSijel = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة 'قراءة قيم البحث من بطاقة الموظف startDate = wsBataka.Range("A2").Value endDate = wsBataka.Range("B2").Value employeeName = wsBataka.Range("C2").Value movementType = wsBataka.Range("D2").Value 'مسح البيانات القديمة في بطاقة الموظف lastRowBataka = wsBataka.Cells(wsBataka.Rows.Count, "A").End(xlUp).Row If lastRowBataka >= 6 Then wsBataka.Range("A6:F" & lastRowBataka).ClearContents End If 'إيجاد آخر صف في شيت السجل lastRowSijel = wsSijel.Cells(wsSijel.Rows.Count, "A").End(xlUp).Row 'البحث في السجل وعرض البيانات في بطاقة الموظف j = 6 'بداية كتابة البيانات في بطاقة الموظف من الصف 6 For i = 2 To lastRowSijel 'بداية البحث من الصف 2 (تخطي العناوين) If wsSijel.Cells(i, 2).Value = employeeName And _ wsSijel.Cells(i, 4).Value = movementType And _ wsSijel.Cells(i, 5).Value >= startDate And _ wsSijel.Cells(i, 5).Value <= endDate Then 'كتابة البيانات في بطاقة الموظف wsBataka.Cells(j, 1).Value = wsSijel.Cells(i, 1).Value 'العمود الأول wsBataka.Cells(j, 2).Value = wsSijel.Cells(i, 2).Value 'اسم الموظف wsBataka.Cells(j, 3).Value = wsSijel.Cells(i, 5).Value 'العمود الثالث wsBataka.Cells(j, 4).Value = wsSijel.Cells(i, 6).Value 'نوع الحركة wsBataka.Cells(j, 5).Value = wsSijel.Cells(i, 7).Value 'التاريخ wsBataka.Cells(j, 6).Value = wsSijel.Cells(i, 8).Value 'العمود السادس wsBataka.Cells(j, 6).NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود j = j + 1 'زيادة الصف لكتابة البيانات في الصف التالي End If Next i MsgBox "تم البحث وعرض البيانات بنجاح." 'Call حساب_مجموع_الساعات Call جمع_الساعات_والدقائق End Sub Sub جمع_الساعات_والدقائق() Dim wsBataka As Worksheet Dim نطاق_الجمع As Range Dim مجموع_الوقت As Double Set wsBataka = ThisWorkbook.Sheets("بطاقة الموظف") 'تغيير اسم الورقة حسب الحاجة ' تحديد نطاق الجمع (F6 إلى آخر خلية في العمود F) Set نطاق_الجمع = Range("F6", Cells(Rows.Count, "F").End(xlUp)) ' جمع القيم في النطاق مجموع_الوقت = WorksheetFunction.Sum(نطاق_الجمع) ' وضع النتيجة في الخلية E4 Range("E4").Value = مجموع_الوقت ' تنسيق الخلية E4 Range("E4").NumberFormat = "[h]:mm" ' أو "h:mm" حسب الحاجة End Sub الخروج والعودة - كود.xlsm

هل هذا هو المطلوب Sub حساب_فرق_الساعات1() Dim wsData As Worksheet, wsSummary As Worksheet Dim lastRowData As Long, lastRowSummary As Long Dim i As Long, j As Long Dim employeeName As String, movementType As String, movementDate As Date Dim exitTime As Date, returnTime As Date, timeDifference As Double Dim totalHours As Double, days As Long, remainingHours As Long Dim summaryDict As Object 'استخدام Dictionary لتجميع الساعات حسب الموظف والشهر 'تعيين ورقتي العمل Set wsData = ThisWorkbook.Sheets("السجل") 'تغيير اسم الورقة حسب الحاجة Set wsSummary = ThisWorkbook.Sheets("احتساب عدد الساعات") 'تغيير اسم الورقة حسب الحاجة 'إيجاد آخر صف في ورقة البيانات lastRowData = wsData.Cells(wsData.Rows.Count, "B").End(xlUp).Row 'إضافة عناوين الأعمدة في ورقة الملخص wsSummary.Cells(1, "A").Value = "اسم الموظف" wsSummary.Cells(1, "C").Value = "نوع الحركة (زمنية)" wsSummary.Cells(1, "D").Value = "إجمالي عدد الساعات" wsSummary.Cells(1, "F").Value = "عدد الأيام والساعات المتبقية" 'إنشاء Dictionary لتجميع الساعات Set summaryDict = CreateObject("Scripting.Dictionary") 'حساب الفرق بين وقت الخروج ووقت العودة For i = 2 To lastRowData employeeName = wsData.Cells(i, "B").Value movementType = wsData.Cells(i, "D").Value movementDate = wsData.Cells(i, "E").Value exitTime = wsData.Cells(i, "F").Value returnTime = wsData.Cells(i, "G").Value 'تأكد من وجود وقت خروج ووقت عودة If IsDate(exitTime) And IsDate(returnTime) Then timeDifference = returnTime - exitTime wsData.Cells(i, "H").Value = timeDifference wsData.Cells(i, "H").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تجميع الساعات إذا كانت الحركة "زمنية" If movementType = "زمنية" Then Dim key As String key = employeeName ' استخدام اسم الموظف فقط كمفتاح If summaryDict.Exists(key) Then summaryDict(key) = summaryDict(key) + timeDifference Else summaryDict(key) = timeDifference End If End If End If Next i 'كتابة ملخص الساعات في ورقة الملخص j = 2 Dim key1 As Variant For Each key1 In summaryDict.Keys employeeName = key1 ' استخدام المفتاح مباشرةً كاسم الموظف totalHours = summaryDict(key1) 'كتابة البيانات في ورقة الملخص wsSummary.Cells(j, "A").Value = employeeName wsSummary.Cells(j, "C").Value = "زمنية" wsSummary.Cells(j, "D").Value = totalHours wsSummary.Cells(j, "D").NumberFormat = "[h]:mm;@" 'تنسيق الخلية مباشرة في الكود 'تحويل الساعات إلى أيام وساعات days = Int(totalHours * 24 / 24) remainingHours = (totalHours * 24) Mod 24 wsSummary.Cells(j, "F").Value = days & " يوم " & remainingHours & " ساعة" j = j + 1 Next key1 MsgBox "تم حساب الفرق بين وقت الخروج ووقت العودة وتلخيص الساعات بنجاح." End Sub الخروج والعودة - كود.xlsm