أبوعيد

وعليكم السلام ورحمة الله وبركاته أنصح باستخدام البرنامج العالمي لعمل الجداول المدرسية aSc Timetable وللاسف لا استطيع تحميل البرنامج هنا لأن حجمه أكبر من المسموح به ولكن يمكن إرساله عبر البريد الالكتروني , أو واتساب مع تحياتي

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

تفضل التقرير اليومي معدل.xlsb

هذه محاولة اوفيسنا (1).xlsx

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

وعليكم السلام ورحمة الله وبركاته بالنسبة لملف الذي أرسلته يحتاج لتعديل حتى يكون احترافيا التعديل يشمل أضافة صفحات أخرى ولا يمكن العمل على صفحة واحدة سوال : بالنسبة لـ "الآجل"، هل هو دين على العميل (تأخر في الدفع) أم دين على المندوب/السائق (عُهدة لم يقم بتوريدها بعد) ؟

تم تعديله الكود بالاستعانة ب AI تفقيط معدل.xlsm

تفضل مثال معدل.xlsx

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

نعم الفاصلة العشرية موجود بالفعل في الفورم في الأعلى زر بلون أخضر مكتوب عليه 0.5 نصف درجة يضيف فقط 0.5 لأنها درجات لا يتعامل المعلمون مع غير هذا الكسر

للاستفادة

جرب هذا test1 ‫‬.xlsx

https://www.officena.net/ib/topic/139246-عمل-مصادقة-بالأكسيل-من-بيانات-sap/#findComment-774215 أهلا بك أخي : الذكاء الاصطناعي جعل المبرمجين عاجزين على كتابة كود بالكامل ولكن أصبح شغلهم هو التعديل على الكود فقط الأكواد الطويلة ( مثل الكود الذي طلبت تعديله ) يحتاج وقت لكتابة وتصحيح الأخطاء أما الذكاء الاصطناعي فيكتبه في 1 دقيقة فقط تقريبا (وربما يستغرق أكثر من هذا الوقت إذا كان الكود طويلا ) هذا القسم ليس مخصصا لشرح الذكاء الاصطناعي ادخل على اليوتيوب وستجد مئات المقاطع تشرح ذلك ولكن انصحك أن تركز على واحد (فقط فقط فقط فقط فقط) من نماذج الذكاء الاصطناعي لأنك مبتدئ فإذا عرفت استخدام هذا النموذج فيمكنك بعد ذلك التنقل بين النماذج المختلفة تقبل تحياتي

تفضل جرب هذا من الذكاء الاصطناع ============== 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

وعليكم السلام ورحمة الله وبركاته المشكلة في الملف نفسه الأسباب المحتملة كود VBA تالف. UserForms أو Modules فيها مشكلة. انقطع حفظ الملف أثناء التعديل. والحل لا بد من فحص الملف نفسه من الداخل لمعرفة سبب المشكلة