أبوعيد

جرب هذا
test1 ‫‬.xlsx

تفضل جرب هذا من الذكاء الاصطناع
==============
Sub sale_m_Optimized()
    Dim wsItemOut As Worksheet, wsPerform As Worksheet, wsAccMove As Worksheet
    Dim wsAccMoveD As Worksheet, wsItemMove As Worksheet
    Dim lastRow As Long, i As Long, nRows As Long
    Dim dataArr As Variant
    Dim performArr As Variant, accMoveDArr As Variant
    Dim itemMoveArr As Variant, accMoveArr As Variant
    Dim docType As String, isReturn As Boolean
    Dim performStart As Long, accMoveDStart As Long
    Dim itemMoveStart As Long, accMoveStart As Long
    
    On Error GoTo CleanUp
    
    ' ═══════════════════════════════════════
    ' إيقاف كل ما يبطئ التنفيذ
    ' ═══════════════════════════════════════
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' ═══════════════════════════════════════
    ' تعريف الأوراق (مرة واحدة فقط)
    ' ═══════════════════════════════════════
    Set wsItemOut = ThisWorkbook.Sheets("itemout")
    Set wsPerform = ThisWorkbook.Sheets("perform")
    Set wsAccMove = ThisWorkbook.Sheets("accmove")
    Set wsAccMoveD = ThisWorkbook.Sheets("AccMove D")
    Set wsItemMove = ThisWorkbook.Sheets("itemmove")
    
    ' ═══════════════════════════════════════
    ' فك الحماية
    ' ═══════════════════════════════════════
    wsPerform.Unprotect Password:="m"
    wsAccMove.Unprotect Password:="m"
    wsAccMoveD.Unprotect Password:="m"
    wsItemMove.Unprotect Password:="m"
    wsItemOut.Unprotect Password:="m"
    
    ' إيقاف الفلاتر
    On Error Resume Next
    wsPerform.Rows("4:4").AutoFilter
    wsAccMoveD.Rows("4:4").AutoFilter
    wsAccMove.Rows("3:3").AutoFilter
    wsItemMove.Rows("4:4").AutoFilter
    wsItemOut.Rows("7:7").AutoFilter
    On Error GoTo CleanUp
    
    ' ═══════════════════════════════════════
    ' التحقق من البيانات الإلزامية
    ' ═══════════════════════════════════════
    With wsItemOut
        If .Cells(2, 2) = "" Or .Cells(5, 2) = "" Or .Cells(8, 2) = "" Or .Cells(2, 5) = "" Then
            MsgBox "أكمل البيانات: نوع الحركة, كود العميل, كود الصنف, الإذن اليدوي"
            .Range("B8").Select
            GoTo CleanUp
        End If
    End With
    
    ' ═══════════════════════════════════════
    ' قراءة القيم الثابتة مرة واحدة
    ' ═══════════════════════════════════════
    docType = wsItemOut.Cells(2, 2).Value
    isReturn = (docType = "مردودات مبيعات")
    
    ' ═══════════════════════════════════════
    ' حساب عدد صفوف البيانات
    ' ═══════════════════════════════════════
    lastRow = wsItemOut.Cells(wsItemOut.Rows.Count, 2).End(xlUp).Row
    If lastRow < 8 Then GoTo CleanUp
    nRows = lastRow - 7
    
    ' قراءة كل بيانات المصدر في مصفوفة واحدة (B8:M...)
    dataArr = wsItemOut.Range("B8:M" & lastRow).Value
    
    ' ═══════════════════════════════════════
    ' حساب صف البداية في كل شيت (مرة واحدة)
    ' ═══════════════════════════════════════
    performStart = wsPerform.Cells(wsPerform.Rows.Count, 1).End(xlUp).Row + 1
    accMoveDStart = wsAccMoveD.Cells(wsAccMoveD.Rows.Count, 1).End(xlUp).Row + 1
    itemMoveStart = wsItemMove.Cells(wsItemMove.Rows.Count, 1).End(xlUp).Row + 1
    accMoveStart = wsAccMove.Cells(wsAccMove.Rows.Count, 1).End(xlUp).Row + 1
    
    ' ═══════════════════════════════════════
    ' تهيئة المصفوفات للشيتات الأربعة
    ' ═══════════════════════════════════════
    ReDim performArr(1 To nRows, 1 To 21)   ' B:V
    ReDim accMoveDArr(1 To nRows, 1 To 21)  ' B:V
    ReDim itemMoveArr(1 To nRows, 1 To 14)  ' B:O
    ReDim accMoveArr(1 To nRows, 1 To 19)   ' B:T
    
    ' ═══════════════════════════════════════
    ' حلقة واحدة فقط لملء المصفوفات الأربع
    ' ═══════════════════════════════════════
    For i = 1 To nRows
        
        ' ═══ شيت perform (أعمدة B:V) ═══
        performArr(i, 1) = wsItemOut.Cells(3, 2).Value   ' B
        performArr(i, 2) = wsItemOut.Cells(4, 2).Value   ' C
        performArr(i, 3) = wsItemOut.Cells(5, 2).Value   ' D
        performArr(i, 4) = wsItemOut.Cells(6, 2).Value   ' E
        performArr(i, 5) = wsItemOut.Cells(2, 5).Value   ' F
        performArr(i, 6) = dataArr(i, 1)                 ' G (من B)
        performArr(i, 7) = dataArr(i, 2)                 ' H (من C)
        performArr(i, 😎 = dataArr(i, 3)                 ' I (من D)
        performArr(i, 9) = dataArr(i, 4)                 ' J (من E)
        ' K: الكمية (سالب إذا لم يكن مردود)
        If Not isReturn Then
            performArr(i, 10) = dataArr(i, 5) * -1
        Else
            performArr(i, 10) = dataArr(i, 5)
        End If
        performArr(i, 11) = dataArr(i, 6)                ' L (من G)
        performArr(i, 15) = "no"                         ' P
        performArr(i, 21) = docType                      ' V
        
        ' ═══ شيت AccMove D (أعمدة B:V) ═══
        accMoveDArr(i, 1) = wsItemOut.Cells(3, 2).Value  ' B
        accMoveDArr(i, 2) = wsItemOut.Cells(4, 2).Value  ' C
        accMoveDArr(i, 3) = wsItemOut.Cells(5, 2).Value  ' D
        accMoveDArr(i, 4) = wsItemOut.Cells(6, 2).Value  ' E
        accMoveDArr(i, 5) = wsItemOut.Cells(2, 5).Value  ' F
        accMoveDArr(i, 6) = dataArr(i, 1)                ' G
        accMoveDArr(i, 7) = dataArr(i, 2)                ' H
        accMoveDArr(i, 😎 = dataArr(i, 3)                ' I
        accMoveDArr(i, 9) = dataArr(i, 4)                ' J
        accMoveDArr(i, 10) = dataArr(i, 5)               ' K
        accMoveDArr(i, 11) = dataArr(i, 6)               ' L
        accMoveDArr(i, 15) = "no"                        ' P
        accMoveDArr(i, 21) = docType                     ' V
        
        ' ═══ شيت itemmove (أعمدة B:O) ═══
        itemMoveArr(i, 1) = dataArr(i, 1)                ' B
        itemMoveArr(i, 2) = dataArr(i, 2)                ' C
        itemMoveArr(i, 3) = dataArr(i, 3)                ' D
        itemMoveArr(i, 4) = dataArr(i, 4)                ' E
        itemMoveArr(i, 5) = docType                      ' F
        itemMoveArr(i, 6) = wsItemOut.Cells(3, 2).Value  ' G
        itemMoveArr(i, 7) = wsItemOut.Cells(2, 5).Value  ' H
        ' I/J: نفس المنطق الأصلي (أعمدة مختلفة حسب نوع الحركة)
        If Not isReturn Then
            itemMoveArr(i, 9) = dataArr(i, 10)           ' J (من K في المصدر)
        Else
            itemMoveArr(i, 😎 = dataArr(i, 10)           ' I (من K في المصدر)
        End If
        itemMoveArr(i, 11) = wsItemOut.Cells(5, 2).Value ' L
        itemMoveArr(i, 12) = dataArr(i, 12)              ' M (من M في المصدر)
        itemMoveArr(i, 14) = wsItemOut.Cells(4, 2).Value ' O
        
        ' ═══ شيت accmove (أعمدة B:T) ═══
        accMoveArr(i, 1) = wsItemOut.Cells(5, 2).Value   ' B
        accMoveArr(i, 2) = wsItemOut.Cells(6, 2).Value   ' C
        accMoveArr(i, 4) = wsItemOut.Cells(3, 2).Value   ' E
        accMoveArr(i, 5) = wsItemOut.Cells(2, 5).Value   ' F
        accMoveArr(i, 6) = wsItemOut.Cells(4, 2).Value   ' G
        ' H/I: نفس المنطق الأصلي
        If Not isReturn Then
            accMoveArr(i, 7) = wsItemOut.Cells(36, 8).Value  ' H
        Else
            accMoveArr(i, 😎 = wsItemOut.Cells(36, 8).Value  ' I
        End If
        accMoveArr(i, 10) = dataArr(i, 5)                ' K
        accMoveArr(i, 11) = wsItemOut.Cells(34, 8).Value ' L
        accMoveArr(i, 13) = wsItemOut.Cells(35, 8).Value ' N
        accMoveArr(i, 15) = docType                      ' P
        accMoveArr(i, 18) = wsItemOut.Cells(5, 3).Value  ' S
        
    Next i
    
    ' ═══════════════════════════════════════
    ' كتابة المصفوفات دفعة واحدة (أسرع بـ 100 مرة)
    ' ═══════════════════════════════════════
    wsPerform.Range("B" & performStart & ":V" & performStart + nRows - 1).Value = performArr
    wsAccMoveD.Range("B" & accMoveDStart & ":V" & accMoveDStart + nRows - 1).Value = accMoveDArr
    wsItemMove.Range("B" & itemMoveStart & ":O" & itemMoveStart + nRows - 1).Value = itemMoveArr
    wsAccMove.Range("B" & accMoveStart & ":T" & accMoveStart + nRows - 1).Value = accMoveArr
    
    ' ═══════════════════════════════════════
    ' كتابة الصيغ دفعة واحدة لكل نطاق
    ' ═══════════════════════════════════════
    
    ' --- perform ---
    With wsPerform
        .Range("A" & performStart & ":A" & performStart + nRows - 1).FormulaR1C1 = "=IF((R[-1]C)<>""م"",(R[-1]C)+1,1)"
        .Range("N" & performStart & ":N" & performStart + nRows - 1).FormulaR1C1 = "=(RC[-3]*RC[-2])"
        .Range("Z" & performStart & ":Z" & performStart + nRows - 1).FormulaR1C1 = "=IF(RC[-13]>0,RC[-13]*-1,RC[-15])"
        .Range("AA" & performStart & ":AA" & performStart + nRows - 1).FormulaR1C1 = "=IF(RC[-14]>0,(RC[-16]+RC[-14])/RC[-16],0)"
        .Range("AB" & performStart & ":AB" & performStart + nRows - 1).FormulaR1C1 = "=MONTH(RC[-25])"
    End With
    
    ' --- AccMove D ---
    With wsAccMoveD
        .Range("A" & accMoveDStart & ":A" & accMoveDStart + nRows - 1).FormulaR1C1 = "=ROW()-4"
        .Range("N" & accMoveDStart & ":N" & accMoveDStart + nRows - 1).FormulaR1C1 = "=(RC[-3]*RC[-2])"
        .Range("W" & accMoveDStart & ":W" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(RC[-21]<>R[-1]C[-21],SUMIFS(C[-9],C[-21],RC[-21],C[-1],RC[-1]),0)"
        
        If isReturn Then
            .Range("Y" & accMoveDStart & ":Y" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(OR(RC[-3]<>R[-1]C[-3],RC[-23]<>R[-1]C[-23]),SUMIFS(C[-11],C[-23],RC[-23],C[-3],RC[-3]),0)"
        Else
            .Range("X" & accMoveDStart & ":X" & accMoveDStart + nRows - 1).FormulaR1C1 = "=IF(OR(RC[-2]<>R[-1]C[-2],RC[-22]<>R[-1]C[-22]),SUMIFS(C[-10],C[-22],RC[-22],C[-2],RC[-2]),0)"
        End If
        
        .Range("Z" & accMoveDStart & ":Z" & accMoveDStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R4C[-2]:RC[-2],R4C[-22]:RC[-22],RC[-22])-SUMIFS(R4C[-1]:RC[-1],R4C[-22]:RC[-22],RC[-22])"
    End With
    
    ' --- itemmove ---
    With wsItemMove
        .Range("A" & itemMoveStart & ":A" & itemMoveStart + nRows - 1).FormulaR1C1 = "=IF((R[-1]C)<>""م"",(R[-1]C)+1,1)"
        .Range("K" & itemMoveStart & ":K" & itemMoveStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R5C[-2]:RC[-2],R5C[-9]:RC[-9],RC[-9])-SUMIFS(R5C[-1]:RC[-1],R5C[-9]:RC[-9],RC[-9])"
    End With
    
    ' --- accmove ---
    With wsAccMove
        .Range("A" & accMoveStart & ":A" & accMoveStart + nRows - 1).FormulaR1C1 = "=ROW()-3"
        .Range("J" & accMoveStart & ":J" & accMoveStart + nRows - 1).FormulaR1C1 = "=SUMIFS(R4C[-2]:RC[-2],R4C[-8]:RC[-8],RC[-8])-SUMIFS(R4C[-1]:RC[-1],R4C[-8]:RC[-8],RC[-8])"
        .Range("T" & accMoveStart & ":T" & accMoveStart + nRows - 1).FormulaR1C1 = "=MONTH(RC[-13])"
    End With
    
    ' ═══════════════════════════════════════
    ' تصفية itemout
    ' ═══════════════════════════════════════
    wsItemOut.Range("A7:H40").AutoFilter Field:=2, Criteria1:="<>"
    
CleanUp:
    ' ═══════════════════════════════════════
    ' إعادة الحماية والإعدادات (دائماً تنفذ)
    ' ═══════════════════════════════════════
    On Error Resume Next
    wsPerform.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    wsItemMove.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    wsAccMove.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    wsAccMoveD.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    wsItemOut.Protect Password:="m", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

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

الشرح يطول ولكن ثق تماما أنك بمجرد أن تفتحه وتثبت الماكرو وتستخدمه ستفهم البرنامج
ثم بعد التجربة أذا أردت أي توضيح نحن في الخدمة
محرر الأكواد مفتوح ويمكنك التعديل عليه كما تريد

الطريقة : افتح ملفك الذي تريد الأدخال فيه ثم افتح هذا الملف
ثم اضغط على إحدى الأيقونتين (الدرجات أو التاريخ)
وعندما يفتح الفورم انتقل مباشرة إلى ملفك الذي تريد الأدخال فيه
ستجد أن الفورم ينتقل إلى الملف الجديد
تفضل
إدخال الدرجات والتاريخ.xls

تفضل
Horaire 2.xlsb

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

وعليكم السلام ورحمة الله وبركاته
الطريقة
حدّد كل الجدول (أو النطاق الكبير اللي تشتغل فيه).
من القائمة: اختر
(تنسيق شرطي) ثم (قاعدة جديدة) ثم (استخدام صيغة لتحديد الخلايا المراد تنسيقها)
اكتب الصيغة التالية: 
=ROW()=CELL("row")
اختر اللون اللي تحبّه.
اضغط (موافق) 
الأن كلما تكتب في أي خلية في السطر اضغط السهم لليمين أو اليسار وواصل الكتابة ـ يعني لاتنزل سطر جديد ولكن تابع الكتابة في نفس السطر

تقبل تحياتي

الموقع : https://www.araby.ai/
شرح الموقع https://youtu.be/U4l2mnnh0ZY

الموقع : https://gemini.google.com/app?hl=ar
الموقع : https://chatgpt.com/
الموقع : https://chat.deepseek.com/
وعيرها كثيرررررررر
 
 

لا أعلم المشكلة
الملف يعمل عندي بشكل ممتاز
عند ظهور هذه الرسالة اضغط زر DEBUG
سيتم تلوين السطر المشكل بلون اصفر
ما هو السطر المشكل ؟

تفضل اختر ما يناسبك
دمج مبلغ1.xlsx

تفضل جرب
مثال1.xlsx

إذا تطابق اللون والوصف والمقاس سيتم ألغاء الإضافة
Private Sub CommandButton1_Click() Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim WS As Worksheet, rng As Range Dim lastRow As Long Set WS = Sheet1 If Me.TextBox4 = "" Then: Exit Sub '======= lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow ' äÈÏà ãä ÇáÕÝ 2 assuming ÇáÕÝ ÇáÃæá ÚäÇæíä If WS.Cells(i, 2).Value = Me.TextBox1.Value _ And WS.Cells(i, 3).Value = Me.TextBox7.Value _ And WS.Cells(i, 4).Value = Me.TextBox2.Value _ Then MsgBox "ÇáÈíÇäÇÊ ÇáÊí ÊÍÇæá ÃÖÇÝÊåÇ ãæÌæÏÉ ãä ÞÈá", vbOKOnly, "ÈíÇäÇÊ ãßÑÑÉ" Exit Sub End If Next i '======= Set rng = WS.Range("a2100").End(xlUp).Offset(1, 0) rng.Offset(0, 0).Value = Me.TextBox4.Value rng.Offset(0, 1).Value = Me.TextBox1.Value rng.Offset(0, 3).Value = Me.TextBox2.Value rng.Offset(0, 5).Value = Me.TextBox3.Value rng.Offset(0, 6).Value = Me.TextBox5.Value rng.Offset(0, 7).Value = Me.TextBox6.Value rng.Offset(0, 2).Value = Me.TextBox7.Value For i = 1 To 7 Controls("textbox" & i).Text = Empty Next i Application.ScreenUpdating = True Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub  

المطلوب الأول هو من جنس المطلوب الثاني ولا داعي لتكرار الجداول
المعادلات المستخدمة هي من نوع الصفيف وليست معادلات عادية
تفضل
example1.xlsx

السلام عليكم
هذه محاولة بحسب ما فهمت
حل1 : اختر أول سطر للبيانات من القائمة المنسدلة الزرقاء
حل2 : مباشرة بدون اختبار سيتم اختيار آخر سطر
تفضل
جديد1.xlsm

جرب هذا الملف
maachat3.xlsm

تفضل اضغط على زر استدعاء في البحث ولاحظ النتيجة
الغياب1.xls

السلام عليكم
تم عمل بعض التغييرات في الملف حتى تمشي الأمور تمام التمام

 تم فك الدمج في خلايا الاحتياط لأن معادلة الصفيف لا تقبل الخلايا المدموجة
فقط قم تبغيير الرقم في P1  ولاحظ النتيجة
ملاحظة : كل المعادلات من نوع الصفيف التي تبدأ بقوس وتنتهي بقوس
تفضل جرب الملف
 
_اكمال ملاحظة5.xlsx

تفضل جرب الملف
مصادقة 1.xlsx

وعليكم السلام 
تم تعديل المعادلة في العمود F
تعديل معادلة1.xlsm

استفسار1.xlsx

وعليكم السلام
كل حاجة تمام التمام المعادلة شغالة في K2 , K3
الخلل موجود في الصفحة main في الخلية E2 لا يوجد تاريخ
ادخل على الصفحة والخلية واكتب اي تاريخ ستجد كل شيء تمام التمام
تحياتي

وعليكم السلام
جرب هذا الحل
قوائم التلاميذ معدل.xlsm

ساعرض عليك فيدوهات تشرح الطريقة ولكن يجب أن تشاهدها كلها حتى تختار أسهل طريقة تناسبك
أولا : 
https://youtu.be/pA9ySmQ01iY?si=p9nXmux1nT8qBGgp
ثانيا :
https://youtu.be/sBBKTP1io_M?si=VmXjQmgihaoJqBBy
ثالثا :
https://youtu.be/lgbHqyDsfwg?si=oQzRCmGxXMVsNscA
 

دليل الترحيل في الصفحة 1 بالعمود A  موجود 1 , 2
بينما دليل الترحيل في الصفحة2 بالعمودِA  موجود 1 قثط وبعده 3 ولا يوجد الرقم 2
جرب امسح الرقم 3 في الصفحة 2 في دليل الترحيل واكتب الرقم 2 ولاحظ النتيجة

السلام عليكم
تفضل اكتب فقط رقم الجلوس للطالب في الخلية البنفسجية
ستلاحظ أن المعادلة المستخدمة هي معادلة واحدة المختلف فقط هو رقم العمود في كل معادلة 
قم بتغيير الرقم إذا وجد أي خطا لتصحيحه
 
نتيجة للتجربة1.xlsx

تفضل جرب المرفق
__المرتجع - نسخة1.xlsm