نجوم المشاركات

جرب الملف كود لعمل خط تحت الدرجة الاقل.xlsb

صحح (Lng) الى (Long)

السلام عليكم الموضوع كبير ويحتاج الى خبرة واسعة في البرمجة ولهذا عرضت الامر على الذكاء الاصطناعي فقدم لي الكود على طبق من ذهب وها انا اقدمه لك في ملف اكسل مع رسالتين كمثال يمكتك تعديل الكلمات من الكود لنظهر في الرسائل تعريب الرسائل.xlsb

احسنت أستاذ خليفة ، و انا ماجربت على اكسس 32 بت لان أنا أعمل على أكسس 64 بت (الشرط صواب) و ما ينتقل الى Else وسطر ذي خطاء في Else و ما أخبرني نسيت "O" 😊 و المرفق بعد تعديل FF.mdb

نعم , ولكن الأمر يحتاج لخبرة في مجال الفيجوال بيسك

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, OnRng As Variant, i As Long Dim WS As Worksheet: Set WS = Me Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Not Intersect(Target, WS.Range("C3:C" & WS.Rows.Count)) Is Nothing Then lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i End If Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub كود لعمل خط تحت الدرجة الاقل.xlsb

وعليكم السلام ورحمة الله وبركاته يمكنك الاطلاع على الفيديو الآتي المتعلق بحل مشكلة رسالة الخصوصية كما يلي: من هنا تقبل تحياتي

وعليكم السلام ادخل على محرر الفيجوال لتظهر لك برمجة الرسالة ستلاحظ وجود vbYesNoCancel في سطر البرمجة أضف عليه vbMsgBoxRight + حتى تكون هكذا vbMsgBoxRight +vbYesNoCancel العاملة.xlsm

صباح الخير عتد الانتهاء من ملفك ارفقه وساضع الاكواد به بالتوفيق

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

السلام عليكم مشاركة مع الاساتدة بدون استعلام Private Sub Kind_AfterUpdate() Dim frm As Form If Not IsNull(Me.kind) Then Set frm = Me!AGR.Form frm!kind = Me.kind End If End Sub بالتوفيق Subform (1).accdb

من بعد اذن اخى واستاذى @kkhalifa1960 جزاه الله كل خير @Abdelaziz Osman غير الحدث لعند الخروج Private Sub kind_Exit(Cancel As Integer) DoCmd.RunCommand acCmdSaveRecord DoCmd.SetWarnings False DoCmd.OpenQuery "Query1" DoCmd.SetWarnings True 'Me.Requery Me.AGR.Requery End Sub بالتوفيق

وعليكم السلام بالمعادلات aw1.xlsx

أنا اشتغلت على الموضوع رغم عدم الرد ولكن كي يستفيد من يهمه الأمر ..... 1- يوجد بالفولدر نموذجان وفولدران للصور . أ- النموذج (Watcher) والفولدر (ImagesWatcher) يتم فتح النموذج فيذهب لمسار فولدر صور الاشعة هذا المسار مجرب لمعمل اشعة بجواري . علشان كدة سألت عم المسار ولم يجيبني السائل ... المهم الفورم بيبحث عن أي تغييرات من زياد صور بفولدر جهاز الاشعة ويحفظها بالفولدر (ImagesWatcher) . ب- النموذج (DRTest) والفولدر (Images) يتم فتح النموذج (SwichBoard) وبه العمليات كما بالنموذج . 2- أي استفسار أنا حاضر . واليكم المرفق . Digital Radiography.rar

Navigate to this directory [C:\Program Files (x86)\Microsoft Office\root\vfs\Windows\SHELLNEW] and make sure the file named [EXCEL12.xlsx] exists If the file doesn't exist download it from the post (I will attach it for you) then copy it to the directory in the above screenshot Create an excel shortuct and right-click on it and select [Run as administrator] Finally execute the following code Sub Test() Const SEXCELFILE As String = "EXCEL12.xlsx" Dim subKeys, WshShell As Object, fso As Object, baseKeyPath As String, sFullKeyPath As String, sDestFile As String, sSourceFile As String, i As Integer Set WshShell = CreateObject("WScript.Shell") baseKeyPath = "HKEY_CURRENT_USER\Software\Classes\" subKeys = Array(".xlsx\", "Excel.Sheet.12\", "ShellNew\") sFullKeyPath = baseKeyPath For i = LBound(subKeys) To UBound(subKeys) sFullKeyPath = sFullKeyPath & subKeys(i) If Not RegKeyExists(WshShell, sFullKeyPath) Then WshShell.RegWrite sFullKeyPath, "" Next i sDestFile = "C:\Program Files (x86)\Microsoft Office\root\vfs\Windows\SHELLNEW\" & SEXCELFILE Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(sDestFile) Then sSourceFile = ThisWorkbook.Path & "\" & SEXCELFILE If fso.FileExists(sSourceFile) Then fso.CopyFile sSourceFile, sDestFile Else MsgBox "Source File '" & SEXCELFILE & "' Not Found.", vbExclamation: Exit Sub End If End If WshShell.RegWrite sFullKeyPath & "FileName", sDestFile, "REG_SZ" Set WshShell = Nothing: Set fso = Nothing MsgBox "Done", vbInformation End Sub Function RegKeyExists(WshShell As Object, regKey As String) As Boolean On Error Resume Next WshShell.RegRead regKey RegKeyExists = (Err.Number = 0) On Error GoTo 0 End Function EXCEL12.XLSX

السلام عليكم ورحمة الله وبركاته اسعد الله اوقاتكم بالخير والمسرات اساتذتي واخواني الكرام نظرًا لأني لازلت مبتدئ في عالم الأكسس الجميل قمت بعمل برنامج او ملف لدليل الهاتف وهذه الفكرة ليست بجديدة ولكني حاولت تطبيق الأفكار التي تعلمتها وأنا بحاجة لأعمل عليه في المحل واريد توجيهات وملاحظات على هذا الدليل من جميع النواحي سواء نصائح لتغيير بعض الاشياء او اضافة شيء جديد, وأنتم لن تقصروا باذن الله ^_^ قبل تشغيل الملف قم باستثناء موقع الملف من مركز التوثيق حتى يعمل معك بشكل سليم ينقسم الدليل الى اربعة تبويبات : 1- تبويب معلومات الاتصال ومن خلال هذه النافذة تستطيع اضافة وحفظ اسم او حذفه كذلك تستطيع البحث عن اي اسم وتعديله بالاضافة الى التنقل الى الاسم السابق او التالي 2- تبويب قائمة الاسماء : من خلاله تستطيع استعراض جميع الاسماء ونوعية جهة الاتصال والمجموعات وبجانب كل اسم يوجد زر ( تفاصيل) يؤدي الى المعلومات الكاملة لجهة الاتصال , كذلك تستطيع البحث عن اي اسم 3- تبويب نوع جهة الاتصال : تستطيع من خلاله استعراض جميع انواع جهة الاتصال او اضافة وحذف اي نوع تريد ويوجد بجانب كل نوع زر ( تفاصيل ) يقوم بالفلترة حسب هذا النوع 4- تبويب المجموعات مثل التبويب السابق لكن على شكل مجموعات وتستطيع التحكم بهذه المجموعات من اضافة وحذف او فلترة ‏‏‏‏‏‏‏‏‏‏دليل الهاتف نسخة 5 .rar

السلام عليكم اذا تقصد الفرز من الاعلى رصيد الى الاقل رصيد استخدم الكود التالي Sub ترتيب_تنازلي() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws .Range("A4:E6").Sort Key1:=.Range("E4:E6"), Order1:=xlDescending, Header:=xlNo End With End Sub ويمكنك نعديل نطاق البيانات من الكود الملف عملاء.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي") Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row) txt = "مؤقت لمدة" If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z") CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26") ReDim a(LBound(ColArr) To UBound(ColArr)) For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "") WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "") WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "") Application.ScreenUpdating = False : Application.EnableEvents = False On Error GoTo SubApp For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i SubApp: Application.ScreenUpdating = True: Application.EnableEvents = True End If End If End Sub طلب ترحيل.xls

الدالة لتحويل نتائج دالة التفقيط NoToTxt (لا أعرف كاتبها) إلى أرقام. وقد كتبتها بناءً على طلب أحد أعضاء منتدى الاكسل. Function NoToTxtRev(ByVal TheTxt As String, MyCur As String, MySubCur As String) As Double 'AbuuAhmed, last update 2024/12/30 'Reverse of NoToTxt function Dim Pos As Integer, Step As Byte, Part4 As Integer, Part As Byte Dim i As Byte, ii As Integer Dim Parts(6), a, b, c Dim Text As String Dim Sum4 As Double, Sum As Double Dim Key0, Key1, Key2, Key3 Dim Sp As Integer Dim Pwr As Integer a = Array("", "مائة", "مائتان", "ثلاثمائة", "أربعمائة", "خمسمائة", "ستمائة", "سبعمائة", "ثمانمائة", "تسعمائة", _ "", "عشر", "عشرون", "ثلاثون", "أربعون", "خمسون", "ستون", "سبعون", "ثمانون", "تسعون", _ "", "واحد", "اثنان", "ثلاثة", "أربعة", "خمسة", "ستة", "سبعة", "ثمانية", "تسعة") b = Array("إحدى", "إثنى", "عشرة", "فقط ", "و ", "ملياران", "مليونان", "ألفان", _ "ومليار", "ومليون", "وألف", "فقط مليار", "فقط مليون", "فقط ألف", "فقط ") c = Array("واحد", "اثنان", "صفر عشر", "فقط ", "و", "اثنان مليار", "اثنان مليون", "اثنان ألف", _ "وواحد مليار", "وواحد مليون", "وواحد ألف", "واحد مليار", "واحد مليون", "واحد ألف", "") Key1 = Array("", "مليار", "ملياران", "مليارات") Key2 = Array("", "مليون", "مليونان", "ملايين") Key3 = Array("", "ألف", "ألفان", "آلاف") For i = 0 To UBound(b) TheTxt = Replace(TheTxt, b(i), c(i)) Next i If MyCur & MySubCur <> "" Then Pos = InStr(1, TheTxt, MyCur) If Pos > 0 Then Parts(5) = Replace(Mid(TheTxt, Pos + Len(MyCur)), MySubCur, "") TheTxt = Left(TheTxt, Pos - 1) Else Pos = InStr(1, TheTxt, MySubCur) If Pos > 0 Then Parts(5) = Replace(TheTxt, MySubCur, "") TheTxt = "" End If End If Else Pos = InStr(1, TheTxt, " ") If Pos > 0 Then Parts(5) = Trim(Mid(TheTxt, Pos + 3)) TheTxt = Left(TheTxt, Pos - 1) End If End If For Part = 1 To 3 Key0 = IIf(Part = 1, Key1, IIf(Part = 2, Key2, Key3)) Pos = InStr(1, TheTxt, Key0(1)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(2)) If Pos = 0 Then Pos = InStr(1, TheTxt, Key0(3)) If Pos > 0 Then Parts(Part) = Left(TheTxt, Pos - 1) Pos = InStr(Pos, TheTxt & " ", " ") TheTxt = Mid(TheTxt, Pos) End If Next Part Parts(4) = TheTxt For i = 1 To 5 Parts(i) = Trim(Replace(Parts(i), " و", " ")) Parts(i) = Replace(Parts(i), " احد", " واحد") Next i For Part4 = 0 To 12 Step 3 Part = Part4 / 3 + 1 Sum4 = 0 Sp = 3 - (Len(Parts(Part)) - Len(Replace(Parts(Part), " ", ""))) If Sp < 1 Then Sp = 1 For Step = Sp To 3 Pos = InStr(1, Parts(Part) & " ", " ") Text = Trim(Left(Parts(Part), Pos - 1)) Parts(Part) = Mid(Parts(Part), Pos + 1) If Text <> "" Then For i = 1 To UBound(a) Pwr = 10 ^ (3 - Fix((i - 1) / 10) - 1) ii = i Mod 10 If Text = a(i) Then If Part = 5 Then Sum4 = Sum4 + ii * Pwr Else Sum4 = Sum4 + ii * Pwr * Val("1" & IIf(Part = 5, "", String(9 - Part4, "0"))) End If Exit For End If Next i End If Next Step Sum = Sum + IIf(Part = 5, Sum4 / 100, Sum4) Next Part4 NoToTxtRev = Sum End Function

السلام عليكم ورحمة الله تعالى وبركاته يواجه الكثير من المصممين مشكلة اختلاف اللغة او بمعنى ادق يريد الكثير ان تكون لغة الازرار والتطبيق والرسائل موحدة وهذا ما لا يحدث عندما تكون نسخة الويندوز مثلا انجليزية والتطبيق بمصمم باللغة العربية او حتى يكون التعبير اكثر دقه عندما تختلف لغة واجهة المستخدم فى الويندوز عن اللغة التى يريد المصمم ان تظهر بها كل كبيرة وصغيرة قى التطبيق بما فيها ازرار الرسائل مثال لكى تكون الصورة اكثر وضوحا الرسالة بالعربى وهنا يريد المصمم ان تكون لغة الازرار كذلك بالعربى ولكن لغة واجهة الاستخدام انجليزية وعنوان الزر يظهر تبعا للغة الويندوز تم التغلب عليها مسبقا باستخدام دوال الـ API ولست بصدد الحديث عنها لان بها قيد وهو - شرط لان يتم تغيير اسماء الازرار فى صندوق الرسائل بالاسماء التى يرغب بها المستخدم ان تكوت الخصيصة pop up للنموج = No وهذا فيه تقييد للمصمم وخاصة ان كان يستخدم هذه الخصيصة بالشكل التالى pop up للنموج = Yes وكان الحل البديل هو عمل نموذج للرسائل بدلا من استخدام صندوق الرسائل واعتقد تم عمل ذلك مسبقا فى المنتدى ولكن انا الان اقدمه بافضل اسلوب احترافى واكثر مرونه. لعمل ذلك اولا قم بتصميم نموذج للرسائل واعطه الاسم : frmCustomMessageBox وان اردت تغيير الاسم قم بالتسمية التى تناسبك مع مراعاة تغيير الاسم كذلك فى الكود الذى سوف اقدمه بعد قليل والمستخدم فى الوحدة النمطية العامة الان افتح نموذج الرسائل "frmCustomMessageBox" فى وضع التصميم اضف العناصر التاليه عدد 5 عنصر "Buttons" أزرار أوامر على ان تكون الاسماء للازرار كالتالى : Button0 , Button1 , Button2 , Button3 , Button4 عدد 1 عنصر "Labels" عنوان : على ان يكون اسمه كالتالى : MessageLabel عدد 1 عنصر "Image" صورة : على ان يكون اسمه كالتالى : IconImage والان اضف وحدة نمطية عامة واعطها مثلا الاسم : basCustomMessageBox اضف اليها الكود التالى ' متغير لتخزين رقم الزر الذي تم الضغط عليه في نموذج الرسائل المخصص. Private intPressedButton As Integer ' دالة لعرض صندوق رسائل مخصص ' Parameters: ' - arrMessageLines: مصفوفة تحتوي على أسطر الرسالة. ' - strTitle: عنوان صندوق الرسائل. ' - strButtons: قائمة أزرار مفصولة بفواصل. ' - arrTooltips: مصفوفة تحتوي على تلميحات للأزرار (اختياري). ' - strIconPath: مسار الأيقونة (اختياري). ' Returns: ' - رقم الزر الذي تم الضغط عليه (بدءًا من 0 إلى 4)، أو -1 في حالة حدوث خطأ. Function MsgBx(arrMessageLines As Variant, strTitle As String, strButtons As String, Optional arrTooltips As Variant = Null, Optional strIconPath As String = "") As Integer On Error GoTo ErrorHandler Dim frmCustomMsgBox As Form Dim ctrlCurrent As Control Dim strButtonCaption As Variant Dim intButtonIndex As Integer Dim arrButtonCaptions As Variant Dim strMessage As String Dim strLine As Variant Dim strFormName As String strFormName = "frmCustomMessageBox" ' بناء الرسالة من الأسطر الممررة strMessage = "" For Each strLine In arrMessageLines If strMessage <> "" Then strMessage = strMessage & vbCrLf ' إضافة سطر جديد بين الأسطر End If strMessage = strMessage & strLine Next strLine ' التحقق إذا كان النموذج مفتوحًا If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then ' إذا كان النموذج مفتوحًا، فقط استعد المرجع إليه Set frmCustomMsgBox = Forms(strFormName) Else ' إذا لم يكن مفتوحًا، افتحه DoCmd.OpenForm strFormName, acNormal, , , , acHidden Set frmCustomMsgBox = Forms(strFormName) End If ' إعداد خصائص النموذج With frmCustomMsgBox .Caption = strTitle .Controls("MessageLabel").Caption = strMessage ' إظهار التسمية فقط إذا كان هناك نص .Controls("MessageLabel").Visible = (strMessage <> "") ' إضافة الأزرار الجديدة بناءً على strButtons intButtonIndex = 0 arrButtonCaptions = Split(strButtons, ",") For Each strButtonCaption In arrButtonCaptions With .Controls("Button" & intButtonIndex) .Caption = strButtonCaption .Visible = True .OnClick = "=PressedButton(" & intButtonIndex & ")" ' تعيين التلميحات للأزرار إذا تم تمريرها If Not IsNull(arrTooltips) And IsArray(arrTooltips) Then If intButtonIndex <= UBound(arrTooltips) Then .ControlTipText = arrTooltips(intButtonIndex) End If End If End With intButtonIndex = intButtonIndex + 1 Next strButtonCaption ' تعيين الأيقونة إذا كان مسارها موجودًا If strIconPath <> "" Then If Dir(strIconPath) <> "" Then ' إذا كانت الأيقونة موجودة، قم بتعيينها On Error Resume Next ' تجاهل الخطأ إذا حدث .Controls("IconImage").Picture = strIconPath If Err.Number <> 0 Then ' إذا حدث خطأ، أخفي عنصر التحكم .Controls("IconImage").Visible = False Err.Clear Else .Controls("IconImage").Visible = True End If On Error GoTo ErrorHandler ' العودة إلى إدارة الأخطاء العادية Else ' إذا لم تكن الأيقونة موجودة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If Else ' إذا لم يتم تمرير أيقونة، أخفي عنصر التحكم .Controls("IconImage").Visible = False End If End With ' إظهار النموذج كمودال DoCmd.OpenForm strFormName, acNormal intPressedButton = -1 ' انتظار المستخدم لتحديد زر Do DoEvents Loop Until intPressedButton > -1 ' إرجاع القيمة وإغلاق النموذج DoCmd.Close acForm, strFormName, acSaveNo MsgBx = intPressedButton Exit Function ErrorHandler: ' إرجاع قيمة تشير إلى فشل العملية MsgBx = -1 MsgBox "حدث خطأ: " & Err.Number & " | " & Err.Description Debug.Print "حدث خطأ: " & Err.Number & " | " & Err.Description Exit Function End Function Function PressedButton(intButtonIndex As Integer) ' تسجيل الرقم الخاص بالزر المضغوط intPressedButton = intButtonIndex End Function والان طريقة الاستدعاء من اى زر امر لهواة الاختصار فى الاكواد من اى نموذج تكون كالتالى ' تعريف متغير لتخزين نتيجة اختيار المستخدم من النافذة المنبثقة Dim Result As Integer Result = MsgBx(Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟"), "تحذير", "نعم,لا", Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء"), "Full-Path\error.png") If Result = 0 Then MsgBox "تم اختيار موافق" ElseIf Result = 1 Then MsgBox "تم اختيار إلغاء" End If ولكن الطريقة الأمثل لسهولة التعديل والاضافة والصيانة فى المستقبل يكون الاستدعاء بالشكل التالى ' تعريف المتغيرات المستخدمة Dim MessageLines As Variant ' تخزين سطور الرسالة (نص رئيسي وفرعي) Dim TitleText As String ' عنوان النافذة المنبثقة Dim ButtonsText As String ' نص الأزرار (مفصولة بفواصل) Dim Result As Integer ' نتيجة اختيار المستخدم Dim IconPath As String ' مسار ملف أيقونة التحذير Dim Tooltips As Variant ' تلميحات توضيحية عند التمرير على الأزرار ' تعيين مسار ملف الأيقونة التحذيرية (يجب التأكد من صحة المسار) IconPath = "Full-Path\error.png" ' تهيئة محتوى الرسالة: MessageLines = Array("سيتم حذف جميع البيانات", "هل أنت متأكد من المتابعة؟") TitleText = "تحذير" ' عنوان النافذة المنبثقة ButtonsText = "نعم,لا" ' خيارات الأزرار (الزر الأول: نعم، الزر الثاني: لا) ' تعيين التلميحات التوضيحية عند تمرير الماوس على الأزرار: ' تلميح للزر الأول (نعم) ' تلميح للزر الثاني (لا) Tooltips = Array("اضغط هنا للموافقة", "اضغط هنا للإلغاء") ' استدعاء الدالة المخصصة لعرض الرسالة: ' محتوى الرسالة -العنوان - اسماء الأزرار - التلميحات - مسار الأيقونة Result = MsgBx(MessageLines, TitleText, ButtonsText, Tooltips, IconPath) ' معالجة النتيجة المرجعة من الدالة: If Result = -1 Then ' حالة الخطأ (-1 تعني فشل في عرض الرسالة) MsgBox "حدث خطأ أثناء عرض الرسالة." ElseIf Result = 0 Then ' الزر الأول (نعم) تم اختياره MsgBox "تم اختيار نعم" ElseIf Result = 1 Then ' الزر الثاني (لا) تم اختياره MsgBox "تم اختيار لا" End If لتكون النتيجة كما بالشكل التالى من النموج بدلا من صندوق الرسائل التقليدى طبعا يمكن تغيير اسماء الازرار عند الاستدعاء من السطر : ButtonsText = "نعم, لا" ليكون مثلا ButtonsText = "موافق , الغاء" وطبعا تغير السطر : MsgBox "تم اختيار نعم" باضافة الكود الذى تريده عند الضغط على الزر انا فقط كتبت الرسالة فى كود الاستدعاء لتوضيح انه سوف يتم تنفيذ الامر ملحوظة : استخدام : Tooltips وهو التلميح عندما يحوم الماوس فوق الازرار فى النموذج اختيارى ممكن عدم استخدامه كذلك استخدام : IconPath وهو مسار لصورة ايقونة تدل على الرسالة اختيارى ممكن عدم استخدامه ولكن طبعا انا كتبت الكود بحيث يوفر اكبر قدر ممكن من المرونه فى تناول او عدم تناول هذه الخصائص لمن يريد تغيير الايقونات مع كل رسالة او تغيير عدد او اسماء الازرار مع كل رسالة وكذلك التلميحات للازرار المستخدمه ملاحطة هامة جدا جدا جدا : لا تنسي اخفاء كل ازرار الاوامر الخمسة فى النموذج الكود سوف يقوم بإعادة اظهار الازرار حسب الاستدعاء تحياتى الحارة CustomMessageBox.zip

حل اخر مع اليوم الافتراضي لبداية الاسبوع بالنسبة لي . Sub GroupWeek_2() Dim wb As Workbook: Set wb = ThisWorkbook Dim ws As Worksheet: Set ws = Sheet1 Dim desWS As Worksheet: Set desWS = Sheet2 desWS.Cells.ClearContents: Cells.Interior.ColorIndex = xlNone ws.Range("A1:B1", ws.Range("a" & Rows.Count).End(xlUp)).Copy desWS.Range("A1") GroupByWeek desWS, "a2", "a", "اسبوع " End Sub Sub GroupByWeek( _ ByVal desWS As Worksheet, _ ByVal Clé As String, _ Optional ByVal GroupColumn As Variant = "a", _ Optional ByVal GroupBaseName As String = "اسبوع ") Dim f As Range, IRow As Long, lr& Dim Rng As String Dim minDate As Date, maxDate On Error Resume Next IRow = desWS.Columns("A:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 minDate = Application.WorksheetFunction.Min(desWS.Range("A2:A" & IRow)) maxDate = Application.WorksheetFunction.Max(desWS.Range("A2:A" & IRow)) With Range("a2:a" & IRow) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Exit Sub End If End With Dim fCell As Range: Set fCell = desWS.Range(Clé) Dim lCell As Range Set lCell = fCell.Resize(desWS.Rows.Count - fCell.Row + 1) _ .Find("*", , xlFormulas, , , xlPrevious) If lCell Is Nothing Then Exit Sub Dim rCount As Long: rCount = lCell.Row - fCell.Row + 1 Dim crg As Range: Set crg = fCell.Resize(rCount) Dim Data As Variant If rCount = 1 Then ReDim Data(1 To 1, 1 To 1): Data = crg.Value Else Data = crg.Value End If ReDim Preserve Data(1 To rCount, 1 To 2) Dim CurrValue As Variant Dim CurrDate As Date Dim OldWeek As Long Dim NewWeek As Long Dim sr As Long Dim Cpt As Long For sr = 1 To rCount CurrValue = Data(sr, 1) If IsDate(CurrValue) Then NewWeek = Application.WeekNum(CurrValue) If NewWeek <> OldWeek Then Cpt = Cpt + 1 Set Data(Cpt, 1) = crg.Cells(sr) Data(Cpt, 2) = NewWeek OldWeek = NewWeek End If End If Next sr If Cpt = 0 Then Exit Sub For Cpt = Cpt To 1 Step -1 With Data(Cpt, 1) .EntireRow.Insert xlShiftDown .Offset(-1).EntireRow.Columns(GroupColumn).Value _ = GroupBaseName & Data(Cpt, 2) End With Next Cpt Dim ar As Range For Each ar In desWS.Range("b2:b" & desWS.Range("b" & Rows.Count).End(xlUp).Row + 1).SpecialCells(xlCellTypeConstants).Areas ar.Offset(-1).Resize(1).Value = WorksheetFunction.Sum(ar) Next lr = desWS.Columns("A:b").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row + 1 With desWS.Range("a2:a" & lr) Set f = .Find(What:="اسبوع" & "*", lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not f Is Nothing Then Rng = f.Address Do desWS.Range("a:b").Rows(f.Row).Interior.ColorIndex = 8 f.Interior.ColorIndex = 45 Set f = .FindNext(f) ' Loop While f.Address <> Rng End If End With Application.ScreenUpdating = True MsgBox "من :" & " " & Format(minDate, "dd/mm/yyyy") & vbLf & vbLf & "إلى :" & " " & Format(maxDate, "dd/mm/yyyy"), vbInformation End Sub مجموع كل أسبوع V2.xlsm

جميعا بإذن الله

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

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد أ / محمد صالح وبما انه جاء في طلبك انك ترغب باستخدام الاكواد لابأس في اثراء الموضوع بالكود التالي Sub Extract_days() Dim WSData As Worksheet Dim rng As Range, strDays As String Dim Col As Variant, arDays As Variant Dim iDays As Long, lr As Long, i As Long Set WSData = Worksheets("ورقة2") Application.ScreenUpdating = False WSData.Range("E2", Range("E" & Rows.Count).End(3)).ClearContents With WSData lr = .Range("D" & Rows.Count).End(xlUp).Row Set rng = .Range("B2:G" & lr) Col = rng.Value End With On Error Resume Next For i = 1 To UBound(Col) strDays = "" arDays = Split(Col(i, 3), "-") For iDays = 0 To UBound(arDays) strDays = strDays & "-" & Format(DateSerial(Col(i, 6), Col(i, 5), arDays(iDays)), "dddd") Next iDays Col(i, 4) = Right(strDays, Len(strDays) - 1) Next i On Error GoTo 0 With rng.Columns(4) .Value = Application.Index(Col, 0, 4) '.Columns.AutoFit End With Application.ScreenUpdating = True End Sub الغياب2.xlsm

يمكنك استعمال هذه الدالة المعرفة Function daysnames(d As String, m As Integer, y As Long) As String Dim x As Long, s As String, days: s = "": days = Split(d, "-") For x = 0 To UBound(days) s = s & IIf(x > 0, " و", "") & Format(DateSerial(y, m, days(x)), "dddd") Next x daysnames = s End Function وطريقة استخدامها =daysnames(D2,F2,G2) وبعد استعمالها تعامل مثل الدوال الموجودة في الاكسل من حيث تحديث بيانات الخلية مباشرة بدون الضغط على زر للتحديث بالتوفيق