أبوأحـمـد

وعليكم السلام استبدل المعادلة =IF(C3="";"";(B3+C3)-1)

وعليكم السلام تفضل معادلة فرق النسبة.xlsx

ترددت كثيرا في المشاركة في موضوع هذا العضو والمصلحة العامة تحتم ذكر السبب لأنه ويوجد بعض الأعضاء مثله لا يراعون سياسة المنتدى كفتح موضوع جديد عند تأخر الإجابة في موضوع سابق وأيضا إهمال المواضيع بعد الحصول على الحل مشرفي المنتدى لم يضعوا تحديد أفضل إجابة أو زر إعجاب مكافأة لمن قدم الحل وإنما لتأسيس بنك معلوماتي ومرجع لمن أراد البحث والاستفادة مستقبلا وعدم وجود أفضل إجابة أو إعجابات على الإجابات الصحيحة في المواضيع ستجعل من يبحث يتخطى هذا الموضوع وفائدة أخرى عندما تتفاعل مع من يقدم لك الحل تنمو العلاقة والتواصل الإيجابي بينك وبين الأعضاء فالدعاء وكلمة الشكر والاعجاب هم السبيل الوحيد لذلك ومن خلالها أيضا تقدم خدمة لنفسك فيتسابق الجميع لمشاركتك ومساعدتك سأضع الأكواد هنا للفائدة لأن الملف أشبه بتطبيق EXE متعب في الوصول للأكواد Private Sub CommandButton1_Click() Dim LRow As Long Dim namsh As String Dim wk, wk2 As Worksheet Dim x As Integer Dim check As Boolean namsh = "temp" Set wk = Worksheets("التكويد") 'التأكد من عدم وجود الورقة المؤقته وإضافتها For Each wk2 In Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = False Then With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh End With End If 'ترحيل الصفوف المختارة Set wk2 = Worksheets(namsh) wk2.Range("A1:E9999") = "" LRow = wk.Range("A999").End(xlUp).Row wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1") With wk2 'إضافة المجاميع في الصف الأخير Rowz = Application.WorksheetFunction.Subtotal(2, .Range("A2:A" & Rows(Rows.Count).End(xlUp).Row)) .Range("B" & Rowz + 2) = "الاجمالي" .Range("C" & Rowz + 2) = "=ROUND(SUM(C2:C" & Rowz + 1 & "),2)" .Range("D" & Rowz + 2) = "=ROUND(SUM(D2:D" & Rowz + 1 & "),2)" .Range("E" & Rowz + 2) = "=ROUND(SUM(E2:E" & Rowz + 1 & "),2)" .Columns("A:E").AutoFit 'تنسيق الصف الأخير الخاص بالمجموع ' With wk2.Range("B" & Rowz + 2 & ":E" & Rowz + 2) .AddIndent = True .Font.FontStyle = "Times New Roman" .Font.Size = 16 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Interior.Color = RGB(237, 237, 220) .Font.Bold = False .Font.Bold = True End With .PageSetup.PrintArea = "A1:E" & Rowz + 2 'LRow Application.Dialogs(xlDialogPrint).Show End With ' Application.DisplayAlerts = False 'التأكد من وجود الورقة المؤقته وحذفها If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub If Evaluate("=ISREF('" & namsh & "'!A1)") Then Sheets(namsh).Delete End If Application.DisplayAlerts = True End Sub 'عمل فلتر على محتوى الكمبوبوكس Private Sub CommandButton2_Click() With Worksheets("التكويد").Range("A1:T1") 'إلغاء الفلتر If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If If Me.ComboBox1.Text = "" Then Exit Sub .AutoFilter Field:=3, Criteria1:=Me.ComboBox1.Text '& "*" End With 'استدعاء الطباعة Call CommandButton1_Click 'إلغاء الفلتر If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If End Sub 'ملء الكمبوبوكس بأسماء السلع بعد حذف التكرار Private Sub UserForm_Activate() If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False End If Dim wk As Worksheet Set wk = Worksheets("التكويد") Dim v, e LRow = wk.Range("A999").End(xlUp).Row v = wk.Range("C2:C" & LRow).Value With CreateObject("scripting.dictionary") .comparemode = 1 For Each e In v If Not .exists(e) Then .Add e, Nothing Next If .Count Then Me.ComboBox1.List = Application.Transpose(.keys) End With End Sub 81.xlsm

ما رأيك لو استبدلناها بزر تحكم عادي كيف استخدم زر الزيادة أو نقصان .xlsm

استخدم هذه المعادلة غير النطاق حسب الموجود لديك =SUM(SUMPRODUCT((LEN(A1:A444)>3)*1))

تفضل البيض.xlsx

تفضل 77.xlsm

وعليكم السلام أرجو أن يكون هذا طلبك تعداد.xlsx

وعليكم السلام ورحمة الله وبركاته جميل أستاذنا محمد وهذه مشاركتي =D4-WEEKDAY(D4;16)+1 تحديد يوم وتاريخ بداية كل أسبوع ونهايته حسب التاريخ الحالي.xlsx

وعليكم السلام تفضل شيت مرتبات.xlsx

ضع هذا الكود قبل رسالة تم الترحيل 'نقل الرصيد الحالي من الجدول2 ' إلى رصيد سابق في الجدول1 Dim i As Integer For i = 3 To 10 wk.Range("c" & i) = wk.Range("AB" & i) Next ''''''''''''''''''''''''''

تفضل Book1.xlsx

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

تفضل نسبة التحصيل العلمي للطلاب.xlsb

لأنك لم تطلب وتوضح ذلك test2024.xlsb

تفضل =SUM(B2*360;C2*30;D2)

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

تفضل البيض.xlsx

وعليكم السلام ورحمة الله وبركاته تفضل test2024.xlsb

تفضل شرائح (1).xlsx

بعد رسالة تم الترحيل أو قبلها مع إضافة متغير اسم الورقة wk2. wk2.Rows(2).RowHeight = 35 wk2.Rows("3:10").RowHeight = 25

تعديل ملف المعادلات عرض سند بالمعادلات.xlsx

تفضل جديد (1).xlsb

غير سطر أمر الطباعة هذا ' .PrintOut , , , , True, , , , False 'أمر الطباعة بهذا Application.Dialogs(xlDialogPrint).Show أقترح تعديل عنوان الموضوع إلى: طباعة أعمدة غير متجاورة

تفضل Sub PrintReceipt() Dim LRow As Long Dim namsh As String Dim wk, wk2 As Worksheet Dim x As Integer Dim check As Boolean namsh = "temp" Set wk = Worksheets("التكويد") For Each wk2 In Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = False Then With ThisWorkbook .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = namsh End With End If Set wk2 = Worksheets(namsh) wk2.Range("A1:E9999") = "" LRow = wk.Range("A999").End(xlUp).Row wk.Range("A1:A" & LRow & ",E1:E" & LRow & ",R1:R" & LRow & ",S1:S" & LRow & ",T1:T" & LRow).Copy wk2.Range("A1") wk2.Columns("A:E").AutoFit With wk2 .PageSetup.PrintArea = "A1:E" & LRow .PrintOut , , , , True, , , , False 'أمر الطباعة End With ' حذف الورقة جديدة Application.DisplayAlerts = False If ThisWorkbook.Worksheets.Count = 1 Then MsgBox "There Is only One Sheet. The Deletion Can't Be Done!", vbCritical: Exit Sub If Evaluate("=ISREF('" & namsh & "'!A1)") Then Sheets(namsh).Delete End If Application.DisplayAlerts = True End Sub