أبوأحـمـد

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


مواقيت الصلاة.xlsb

استخدم الدالة COUNTIF
ثم قم بفرز نتيجة الدالة واحذف المكرر
المثال بالمرفق
=COUNTIF(A:A;D2)  
المصنف1.xlsx

وعليكم السلام ورحمة الله وبركاته
إذا كان اصدار الأكسل لديك لا يدعم الصفيف فلابد من ضغط كنترول +شفت + انتر
ctrl+shift +enter   بعد تحرير المعادلة 
مصنف (2).xlsx

جرب الآن
 
تعديل بسيط.xlsm

وعليكم السلام
تفضل
فيها نموذج صفحة التقرير يمكنك التعديل عليها وسينعكس ذلك على شيت عهد المعلمين ولكن لا تعدل على عدد الصفوف زيادة ونقصا دون التعديل على الكود
edit.xlsm

تفضل
نموذج بحث - مثال.xlsm

وعليكم السلام
إن كنت فهم المطلوب فهذا الحل
استبدل الكود بالتالي
Private Sub CheckBox1_Click() If TextBox1.Text Like "*صنف*" Then For i = 26 To 15 Step -1 If Cells(i, 2) > 0 Then TextBox2.Value = Cells(i, 2): Exit For Next Else For i = 26 To 15 Step -1 If Cells(i, 5) > 0 Then TextBox2.Value = Cells(i, 5): Exit For Next End If End Sub  

أشكرك أخي عمر على كلامك الطيب
بنظرة سريعة على الكود من الأفضل توحيد الإجراء حتى لا يتكرر مع كل صورة واستدعاء الإجراء فقط ليكون بهذا الشكل
ما عليك إلا وضع هذا السطر عند ضغط الصور
Call AddItemL(Label2.Caption) 
فقط غير رقم الليبل
Private Sub Image1_Click() Call AddItemL(Label1.Caption) End Sub Private Sub Image2_Click() 'استدعاء الاجراء ووضع اليبل المناسب لكل صورة Call AddItemL(Label2.Caption) End Sub 'توحيد الإجراء Function AddItemL(LabelC As String) X = 0 For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.List(i, 0) = LabelC Then X = 1 Exit For End If Next i TextBox1 = WorksheetFunction.VLookup(LabelC, Range("d4:h99"), 5, 0) If X = 1 Then 'Me.ListBox1.AddItem Me.ListBox1.List(i, 1) = Me.ListBox1.List(i, 1) + 1 Me.ListBox1.List(i, 2) = Me.ListBox1.List(i, 1) * TextBox1 Else Me.ListBox1.AddItem Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = LabelC Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = 1 Me.ListBox1.List(i, 2) = TextBox1 End If End Function  

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

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

اوفيسنا تايم شيت (1).xlsx

وعليكم السلام ورحمة الله وبركاته
تفضل
=SUMIFS($B$2:$G$2;B3:G3;">0")  
SUM hour.xlsx

وعليكم السلام ورحمة الله وبركاته
بعيدا عن التعقيد وتكرار البيانات 
عملت لك فلتر في ورقة البيانات  وبعد تعديل البيانات تضغط زر حفظ التعديل فيلتغي الفلتر
وبالتالي النتيجة واحدة أرجو أن يؤدي المطلوب
هذي كل الأكواد
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("B1")) Is Nothing Then Range("A2:APL2").AutoFilter Field:=21, Criteria1:=Range("B1") End If End Sub Sub e() Range("A2:APL2").AutoFilter Field:=21 End Sub  
نسخ البيانات - الى الرئيسية .xlsb

تفضل
Private Sub CommandButton1_Click() Dim ws1, ws2, ws3 As Worksheet Dim lastRow, i, RowM2, RowM3 As Long Set ws1 = ThisWorkbook.Sheets("بيانات") Set ws2 = ThisWorkbook.Sheets("حرر") Set ws3 = ThisWorkbook.Sheets("لم يحرر") RowM2 = 8: RowM3 = 8 ws2.Range("A8:D1000") = "" ws3.Range("A8:D1000") = "" lastRow = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row For i = 8 To lastRow If ws1.Cells(i, 5).Value = "حرر" Then ws2.Range("A" & RowM2 & ":D" & RowM2).Value = ws1.Range("A" & i & ":D" & i).Value RowM2 = RowM2 + 1 Else ws3.Range("A" & RowM3 & ":D" & RowM3).Value = ws1.Range("A" & i & ":D" & i).Value RowM3 = RowM3 + 1 End If Next i End Sub  

لم تضف الكود كاملا
نسيت هذا  ضعه في الموديول Module
Function fnd2(n As Long, s As Long) Dim ItemRow As Integer ItemRow = WorksheetFunction.Match(n, Sheet1.Range("A1:A99999"), 0) If ItemRow = Empty Then Beep: Exit Function fnd2 = Sheet1.Range("S" & ItemRow).Value - s End Function  

تفضل
_عملاء 2023م - نسخة.xlsb

وعليكم السلام
تفضل
=IF(MOD(A2;50)=1;B1+1;B1)  
المصنف-50.xlsx

وعليكم السلام ورحمة الله وبركاته
الحل قبل الحذف فك حماية الورقة وحمايتها مرة أخرى بعد الحذف
فك الحماية ActiveSheet.unprotect Password:="123" إعادة الحماية ActiveSheet.protect Password:="123" مع مراعاة رقم الحماية الخاص بك بدل 123  

تفضل
البيض.xlsx

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

تفضل
Private Sub Worksheet_Change(ByVal Target As Range) Dim myRange As Range Dim x As Long Set myRange = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row + 1) If Target.CountLarge > 1 Then Exit Sub If Intersect(Target, myRange) Is Nothing Then Exit Sub If InStr(2, Target, " ") > 0 Then Target.WrapText = True Else Target.WrapText = False Target.ShrinkToFit = True End If Target.EntireRow.AutoFit End Sub  

وعليكم السلام
تفضل
Sub TR7EL() Dim W1, W2 As Worksheet Dim R, C, x As Long Set W1 = Worksheets("الجرد ") Set W2 = Worksheets("النموذج المالي") C = 1 R = 8 For x = 6 To Cells(Rows.Count, "F").End(xlUp).Row If W1.Range("S" & x) > 0 Then W2.Range("B" & R) = W1.Range("E" & x) W2.Range("C" & R) = W1.Range("F" & x) W2.Range("D" & R) = W1.Range("D" & x) W2.Range("E" & R) = W1.Range("C" & x) W2.Range("F" & R) = "" W2.Range("G" & R) = W1.Range("T" & x) W2.Range("H" & R) = W1.Range("U" & x) W2.Range("I" & R) = W1.Range("V" & x) W2.Range("J" & R) = W1.Range("W" & x) W2.Range("K" & R) = W1.Range("X" & x) W2.Range("L" & R) = W1.Range("Y" & x) W2.Range("M" & R) = W1.Range("Z" & x) If C = 15 Then R = R + 13 C = 1 Else R = R + 1 C = C + 1 End If End If Next End Sub  

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

تفضل
77.xlsm

ترددت كثيرا في المشاركة في موضوع هذا العضو 
والمصلحة العامة تحتم ذكر السبب
لأنه ويوجد بعض الأعضاء مثله لا يراعون سياسة المنتدى
كفتح موضوع جديد عند تأخر الإجابة في موضوع سابق
وأيضا إهمال المواضيع بعد الحصول على الحل
مشرفي المنتدى لم يضعوا تحديد أفضل إجابة أو زر إعجاب مكافأة لمن قدم الحل
وإنما لتأسيس بنك معلوماتي ومرجع لمن أراد البحث والاستفادة مستقبلا
وعدم وجود أفضل إجابة أو إعجابات على الإجابات الصحيحة في المواضيع ستجعل من يبحث يتخطى هذا الموضوع
وفائدة أخرى عندما تتفاعل مع من يقدم لك الحل تنمو العلاقة والتواصل الإيجابي بينك وبين الأعضاء
فالدعاء وكلمة الشكر والاعجاب هم السبيل الوحيد لذلك
ومن خلالها أيضا تقدم خدمة لنفسك فيتسابق الجميع لمشاركتك ومساعدتك
سأضع الأكواد هنا للفائدة لأن الملف أشبه بتطبيق 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

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