اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

أبوأحـمـد

03 عضو مميز
  • Posts

    347
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    34

Community Answers

  1. أبوأحـمـد's post in برنامج جاهز مواقيت الصلاة was marked as the answer   
    السلام عليكم ورحمة الله وبركاته
    النسخة تجريبية وبدون أكواد 
    برامج المواقيت كثيرة وأكثر احترافية وفي كل جوال
    ولكن بين فترة وأخرى أحب أن أتحدى الأكسل وفي كل مرة يكسب التحدي ويبدى امكانياته الهائلة


    مواقيت الصلاة.xlsb
  2. أبوأحـمـد's post in طريقة حذف قائمة أرقام محددة من مجموعة أرقام كثيرة was marked as the answer   
    استخدم الدالة COUNTIF
    ثم قم بفرز نتيجة الدالة واحذف المكرر
    المثال بالمرفق
    =COUNTIF(A:A;D2)  
    المصنف1.xlsx
  3. أبوأحـمـد's post in تعديل في معادلة was marked as the answer   
    وعليكم السلام ورحمة الله وبركاته
    إذا كان اصدار الأكسل لديك لا يدعم الصفيف فلابد من ضغط كنترول +شفت + انتر
    ctrl+shift +enter   بعد تحرير المعادلة 
    مصنف (2).xlsx
  4. أبوأحـمـد's post in تعديل بسيط was marked as the answer   
    جرب الآن
     
    تعديل بسيط.xlsm
  5. أبوأحـمـد's post in ترحيل بيانات صف و نسخها في عمود was marked as the answer   
    وعليكم السلام
    تفضل
    فيها نموذج صفحة التقرير يمكنك التعديل عليها وسينعكس ذلك على شيت عهد المعلمين ولكن لا تعدل على عدد الصفوف زيادة ونقصا دون التعديل على الكود
    edit.xlsm
  6. أبوأحـمـد's post in دالة / معادلة لحساب عدد القيم الفريدة في نطاق محدد was marked as the answer   
    تفضل
    نموذج بحث - مثال.xlsm
  7. أبوأحـمـد's post in تعديل في كود جلب اخر قيمة was marked as the answer   
    وعليكم السلام
    إن كنت فهم المطلوب فهذا الحل
    استبدل الكود بالتالي
    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  
  8. أبوأحـمـد's post in ازالة الفرغات فى اليست بوكس عند الترحيل was marked as the answer   
    أشكرك أخي عمر على كلامك الطيب
    بنظرة سريعة على الكود من الأفضل توحيد الإجراء حتى لا يتكرر مع كل صورة واستدعاء الإجراء فقط ليكون بهذا الشكل
    ما عليك إلا وضع هذا السطر عند ضغط الصور
    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  
  9. أبوأحـمـد's post in مساعدة فى عمل ترقيم تلقائى was marked as the answer   
    وعليكم السلام
    يمكن أيضا عمل الفكرة بالكود أمر طباعة وزيادة العدد
    ويمكن إضافة عبارات مع الرقم
    تفضل
     
    أرقام.xlsx
  10. أبوأحـمـد's post in احتاج معادلة لإيجاد أعمدة غير مكررة بشرط ( بين تاريخيهن ) was marked as the answer   
    الخطأ بسبب أنك وضعت دالة في اسم الموظف في صفحة المدخلات تجلب الاسم من صفحة كشف الدوم التي سنحل لها الأسماء بدون تكرار 
     
    ولتسهيل العمل عليك وتجنبا لمدخلات خاطئة وضعت صفحة فيها أسماء الموظفين وفي صفحة المدخلات فقط اختر الموظف من القائمة وسيظهر الرقم الوظيفي تلقائيا ما عليك إلا استكمال بيانات الإجازة

    اوفيسنا تايم شيت (1).xlsx
  11. أبوأحـمـد's post in مساعدة في كود يقوم بجمع الساعات في صف للخلايا التي فيها رقم فقط was marked as the answer   
    وعليكم السلام ورحمة الله وبركاته
    تفضل
    =SUMIFS($B$2:$G$2;B3:G3;">0")  
    SUM hour.xlsx
  12. أبوأحـمـد's post in نسخ إلى الورقة الرئيسية was marked as the answer   
    وعليكم السلام ورحمة الله وبركاته
    بعيدا عن التعقيد وتكرار البيانات 
    عملت لك فلتر في ورقة البيانات  وبعد تعديل البيانات تضغط زر حفظ التعديل فيلتغي الفلتر
    وبالتالي النتيجة واحدة أرجو أن يؤدي المطلوب
    هذي كل الأكواد
    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
  13. أبوأحـمـد's post in المساعدة فى الترحيل was marked as the answer   
    تفضل
    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  
  14. أبوأحـمـد's post in رسالة تحذير was marked as the answer   
    لم تضف الكود كاملا
    نسيت هذا  ضعه في الموديول 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  

  15. أبوأحـمـد's post in مساعدة في الكود was marked as the answer   
    تفضل
    _عملاء 2023م - نسخة.xlsb
  16. أبوأحـمـد's post in عمل تسلسل في ملف بشرط was marked as the answer   
    وعليكم السلام
    تفضل
    =IF(MOD(A2;50)=1;B1+1;B1)  
    المصنف-50.xlsx
  17. أبوأحـمـد's post in حل مشكلة حذف صف يحتوي على خلية مؤمنة was marked as the answer   
    وعليكم السلام ورحمة الله وبركاته
    الحل قبل الحذف فك حماية الورقة وحمايتها مرة أخرى بعد الحذف
    فك الحماية ActiveSheet.unprotect Password:="123" إعادة الحماية ActiveSheet.protect Password:="123" مع مراعاة رقم الحماية الخاص بك بدل 123  
  18. أبوأحـمـد's post in كود تحويل كرتونة بيض was marked as the answer   
    تفضل
    البيض.xlsx
  19. أبوأحـمـد's post in ملف اكسل رواتب الموظفين was marked as the answer   
    وعليكم السلام
    تفضل
    شيت مرتبات.xlsx
  20. أبوأحـمـد's post in تنسيق الخليه بشرط was marked as the answer   
    تفضل
    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  
  21. أبوأحـمـد's post in ترحيل بشرط was marked as the answer   
    وعليكم السلام
    تفضل
    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  
  22. أبوأحـمـد's post in معادلة توضيح الفرق بين نسبتين شهرين يتم تحديد الشهر بقائمة منسدلة was marked as the answer   
    وعليكم السلام
    تفضل
    معادلة فرق النسبة.xlsx
  23. أبوأحـمـد's post in تعديل على رصيد المخزن was marked as the answer   
    تفضل
    77.xlsm
  24. أبوأحـمـد's post in طباعة اختيار خامة معينة was marked as the answer   
    ترددت كثيرا في المشاركة في موضوع هذا العضو 
    والمصلحة العامة تحتم ذكر السبب
    لأنه ويوجد بعض الأعضاء مثله لا يراعون سياسة المنتدى
    كفتح موضوع جديد عند تأخر الإجابة في موضوع سابق
    وأيضا إهمال المواضيع بعد الحصول على الحل
    مشرفي المنتدى لم يضعوا تحديد أفضل إجابة أو زر إعجاب مكافأة لمن قدم الحل
    وإنما لتأسيس بنك معلوماتي ومرجع لمن أراد البحث والاستفادة مستقبلا
    وعدم وجود أفضل إجابة أو إعجابات على الإجابات الصحيحة في المواضيع ستجعل من يبحث يتخطى هذا الموضوع
    وفائدة أخرى عندما تتفاعل مع من يقدم لك الحل تنمو العلاقة والتواصل الإيجابي بينك وبين الأعضاء
    فالدعاء وكلمة الشكر والاعجاب هم السبيل الوحيد لذلك
    ومن خلالها أيضا تقدم خدمة لنفسك فيتسابق الجميع لمشاركتك ومساعدتك
    سأضع الأكواد هنا للفائدة لأن الملف أشبه بتطبيق 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
  25. أبوأحـمـد's post in كيفية عد الخلايا بها نصوص مع عدم حساب خلايا فارغة بها معادلة was marked as the answer   
    استخدم هذه المعادلة
    غير النطاق حسب الموجود لديك
    =SUM(SUMPRODUCT((LEN(A1:A444)>3)*1))  
×
×
  • اضف...

Important Information