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

استخدم الدالة Round ، وهذا تعديل على مثالي في مشاركة سابقة Private Sub value2_AfterUpdate() ' التأكد من أن القيمة في الحقل الأول (value1) ليست صفر If Nz(Me.value1, 0) <> 0 Then ' حساب النسبة المئوية Dim percentageValue As Double percentageValue = (Me.value2 / Me.value1) * 100 ' تقريب النتيجة لأقرب عدد كسري مع حد أقصى من خانتين عشريتين Me.percentage = Round(percentageValue, 2) & " %" End If End Sub

جزاك الله خير مبدع ولك كل الشكر والتقدير

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_Sheet() 'انشاء ورقة جديدة وتسميتها وفق التسلسل المطلوب Dim f As Worksheet, Msg As Variant, Data As Worksheet Dim WSname As String, Cpt As String Set Data = Sheets("T1") WSname = "SMS" & Format(Date, "DDMMYY") Msg = MsgBox("انشاء ورقة جديدة؟", vbYesNo, WSname) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next Cpt = Worksheets(WSname).Name If Cpt = "" Then Data.Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) ' اظافة تاريخ واسم اليوم Set f = ActiveSheet f.Name = WSname: f.[E1].Value = Date: f.[C1].Value = Format(Date, "DDDD") '*******للاحتفاظ بالصيغ يمكنك الغاء هدا السطر With f.ListObjects(1).DataBodyRange .Value = .Value End With '********************************************** Else MsgBox "ورقة العمل موجودة مسيقا" & _ "", vbInformation, WSname End If .ScreenUpdating = True .DisplayAlerts = True End With End Sub Sub Save_folder_PDF() 'PDF '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String, Msg As Variant Msg = MsgBox("؟" & " " & "PDF " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False On Error Resume Next path = ThisWorkbook.path & "\" folderName = "ملفات PDF" MkDir path & folderName Fname = folderName & "\" & WS.Name & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=path & Fname ScreenUpdating = True .DisplayAlerts = True End With MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName On Error GoTo 0 End Sub Sub Save_folder_Excel() 'Excel '<-- حفظ داخل مجلد في نفس مسار الملف الرئيسي Dim WS As Worksheet: Set WS = ActiveWorkbook.Sheets(Worksheets.Count) Dim path As String, folderName As String, Fname As String path = ThisWorkbook.path & "\" On Error Resume Next Msg = MsgBox("؟" & " " & "Excel " & ":" & " تصدير الملف بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub With Application .ScreenUpdating = False .DisplayAlerts = False folderName = "ملفات Excel" MkDir path & folderName Fname = folderName & "\" & WS.Name WS.Copy Application.ActiveWorkbook.SaveAs fileName:=path & Fname & ".xlsx", FileFormat:=51 ActiveWorkbook.Close .DisplayAlerts = True .ScreenUpdating = True End With On Error GoTo 0 MsgBox "تم حفظ الملف بنجاح" & vbLf & vbLf & path & _ "", vbInformation, folderName End Sub مع اظافة امكانية تنفيد الاكواد بطريقة اخرى ستجدها داخل الملف المرفق بالتوفيق... نمودج V2.xlsb

لا يوجد عندي فكرة محددة في الوقت الحالي اذا كانت الطريقة ممكن تكون برمجياً ، ولكن ان وجدت شيئاً ستجده هنا إن شاء الله .

ولا يهمك أخي الكريم ، قد يكون الأمر غاب عن بالي ولم التفت لهذه النقطة

عفوا عفوا أخى Foksh تم المراد والحمد لله والشكر الجميل لك ولجهدك الرائع كل ما فى الأمر تم تغيير التجميع حسب فى الاستعلام من First الى Last وتم المراد والحمد لله زادك الله عز وجل رفعة وعزة سأحاول تطبيق ما تم على النماذج الأخرى سأنتظر ردك ومن ثم اختيار أفضل إجابة بالطبع ...

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

تفضل يا صديقي ، هذا طلبك ؟ basept.accdb

وعليكم السلام ورحمة الله وبركاته تفضل أخي الكريم: حسب فهمي لسؤالكم الكريم =IF(E8>H8;H8;IF(AND(E8<H8;E8>G8);G8;E8)) للبدلات.xlsx