كل الانشطه

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

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

أخي أبو الحسن عد إلى هذه المشاركة وافتح الماكرو AutoEXEC لاحظ في الصورة الرقم 3 يشير إلى اسم أول نموذج يفتح في قاعدة البيانات .. عدله إلى اسم النموذج الذي لديك .. 🙂 ولا تنسى تعدل اسم الجدول أيضا والمشار إليه بالرقم 1 ..

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

هذي المرة ضع ملفك أخي أبو الحسن 🙂

الف شكر أخي ابو مروان علي الاهتمام شرحت المطلوب بالمشاركة وأرفقت شيت تحميل البرنامج البرنامج اسمه salary_sale وعند فتح البرنامج يفتح علي الصفحة الافتراضية نكتب في خانة تاريخ التعيين 1/7/1978 وكتب في خانة الدرجة رقم 3 سيتم ظهور التدرج والدخول ب ctrl+w والنزول لأسفل الشيت والتعديل علي تاريخ 1/7/2026. شكرااا جزيلا… 🙏

بارك الله فيك أخي المهذب

السلام عليكم ورحمه الله وبركاته استاذ @ashrafelsisi حاول شرح المطوب وارفاق شيت للعمل عليه ما هو الطلوب بالتحديد

اتفضل الاكواد بعد التعديل لعله يكون المطلوب واخبرنا بالنتجه اليك بعض الاكواد ممكن تساعدك كود مسح الخلايا بعد الترحيل اخر كود الترحيل وغير النطاق زاي ما هو موضع wsSrc.Range("B13:J13").ClearContents لو مش عايز ترحل لو الخلايا فارغه قبل كود الترحيل وغير النطاق زاي ما هو موضح If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then MsgBox "الخلايا فارغة لم يتم الترحيل.", vbExclamation Exit Sub End If Sub Transfer1() Dim wsSrc As Worksheet, wsDst As Worksheet Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil1") If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If If WorksheetFunction.CountA(wsSrc.Range("B6:I6")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If wsDst.Range("A6:I6").Value = wsSrc.Range("B4:J4").Value wsDst.Range("J6:Q6").Value = wsSrc.Range("B6:I6").Value End Sub Sub Transfe12() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil12") If WorksheetFunction.CountA(wsSrc.Range("B9:J9")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B9:J9").Value End Sub Sub Transfe13() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil13") If WorksheetFunction.CountA(wsSrc.Range("B13:J13")) = 0 Then MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation Exit Sub End If nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B13:J13").Value wsSrc.Range("B13:J13").ClearContents End Sub Copy of Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb

نفذت كل شئ وكمان عدلت بيفتح النموذج الاتصال التلقائى وتم الاتصال باستمرار لا ينتقل للنموذج التالى اخى الكريم اين السبب

تم ارفاق شيت اكسيل به رابط تحميل البرنامج خالص الشكر والتقدير ... Update linkes.xlsx

تم ارفاق شيت اكسيل به رابط تحميل البرنامج...شكراا جزيلا Update linkes.xlsx

تمام حاضر... خالص الشكر

حاول ضغط الملف ، وارفاقه. أو ارفعه على موقع مثل ميديا فاير، أو جوجل درايف ... إلخ

للأسف أستاذنا الملف أكبر من المسموح به علي المنتدي ....

السلام عليكم ورحمة الله وبركاته .... الزملاء الأفاضل خبيري ومحترفي الأكسيل الرجاء المساعدة في اضافة علاوة دورية وحافز اضافي لعام 2026 في الشيت المرفق ... المطلوب الأول :- في ورقة عمل ( تدرج_مرتبات ) نريد اضافة علاوة دورية بنسبة 12% في الخلية رقم c142 بنفس الأسلوب ومعادلات العلاوة الدورية السابقة لها التي في الخلية رقم c138 والمأخوذة من الجدول المساعد في الخلية رقم af196 المأخوذة أيضا من الجدول المساعد من الخلية رقم ak245 . المطلوب الثاني :-في ورقة عمل ( مفردات_مرتب ) وحتي تظهر المفردات سنكتب في كود الموظف رقم 10 ونكتب في الحالة الاجتماعية رقم 4 ستظهر المفردات نريد عمل صف ليس به معادلات وأسفل حافز اضافي 2025 ونضيف صف حافز اضافي 2026 بقيمة 750 جنيه بنفس طريقة اضافة حافز اضافي 2025 بحيث عند عمل معاينة للمفردات تظهر قيمة حافز اضافي 2026 بقيمة 750 ... ملحوظة لكي يظهر التدرج للموظف يجب ادخال تاريخ التعيين 1/7/1978 والدرجة 3… تم ارفق شيت اكسيل لتحميل البرنامج بالمرفقات خالص الشكر والتقدير للأخوة الكرام Update linkes.xlsx

حاضر أستاذنا الفاضل ... خالص الشكر والتقدير ... سيتم اضافة المطلوب وان شاء الله

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

استاذ يارك لله فيك استاذ الحقول بالون الابيض هل تسطيع تعديل بترحيل مرة واحدة استاذ ورقة Feuil1 قد قمت بتعديل عليها الحقول يكون في صف واحد استاذ الحقول بالون الاصفر يتم افراغ الحقول استاذ عند تكون الحقول فارغ لا يتم الترحيل بارك الله فيك Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb

السلام عليكم ورحمه الله وبركاته قمت سابقا بتنفيذ تلك الفكرة وتعمل بكفاءة عالية وبمنتهى السلاسة إذا حابب تتطلع إلى الفكرة ما عندى مشكله إطلاقا السلام عليكم ورحمه الله وبركاته قمت سابقا بتنفيذ تلك الفكرة وتعمل بكفاءة عالية وبمنتهى السلاسة إذا حابب تتطلع إلى الفكرة ما عندي اى مشكله إطلاقا

وعليكم السلام ورحمة الله وبركاته.. حجزت مقعدي الثاني في المتابعة 😀

شكر وتقدير واحترام من القلب

شششششششششششششششششششكرا جزيلا

وعليكم السلام ورحمه الله وبركاته اتفضل الكود بالطلب الاول لعله يكون المطلوب 👇 Sub TransferDataValues() Dim wsSrc As Worksheet, wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil1") nextRow = wsDst.Cells(wsDst.Rows.Count, "A") '.End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow End If wsDst.Cells(nextRow, "A").Resize(4, 9).Value = wsSrc.Range("B3:J6").Value End Sub اتفضل الكود بالطلب التاني لعله يكون المطلوب 👇 Sub Transfe12() Dim wsSrc As Worksheet Dim wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil12") nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B9:J9").Value End Sub اتفضل الكود بالطلب التالت لعله يكون المطلوب 👇 Sub Transfe13() Dim wsSrc As Worksheet Dim wsDst As Worksheet Dim nextRow As Long Set wsSrc = ThisWorkbook.Worksheets("Horaire2027") Set wsDst = ThisWorkbook.Worksheets("Feuil13") nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If nextRow < 5 Then nextRow = 5 Else nextRow = nextRow + 1 End If wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B13:J13").Value wsSrc.Range("B13:J13").ClearContents End Sub Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb

السلام عليكم لدي ورقة Horaire2027 اريد ترحيل البيانات الى ورقة Feuil1 و Feuil12 و Feuil13 1- ترحيل البيانات الى الورقة Feuil1 الحقول بالون الأزرق لا تفرغ الحقول عند الترحيل 2-ترحيل البيانات الى الورقة Feuil12 الحقول بالون الأصفر وعند الترحيل تفرغ الحقول 3-ترحيل البيانات الى الورقة Feuil13 الحقول بالون الأحمر وعند الترحيل تفرغ الحقول Horaire-18-06-2026-(04.12.06) (3).xlsb