ياسين ( أبو وسام )

فنان :)

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

السلام عليكم ورحمة الله وبركانه اسعد الله ايامكم واتمها بالخير الرجاء المساعدة في اضافة تعديل على كود الترحيل ()Sub TransferData Dim WS As Worksheet, SH As Worksheet Dim X As Long Set WS = Sheets("ترحيل"): Set SH = Sheets("MP LIST") X = SH.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False With SH .Cells(X, 1) = .Cells(X, 1).Row - 2 .Cells(X, 2).Resize(, 3) = Application.Transpose(WS.Range("G9").Resize(3)) .Cells(X, 5).Resize(, 7) = Application.Transpose(WS.Range("G14").Resize(7)) .Cells(X, 12) = WS.Range("G22") .Cells(X, 13).Resize(, 5) = Application.Transpose(WS.Range("G24").Resize(5)) .Cells(X, 18) = WS.Range("I28") .Cells(X, 19) = WS.Range("G30") .Cells(X, 23) = WS.Range("G32") .Cells(X, 27) = WS.Range("G13") .Cells(X, 28) = WS.Range("I13") .Cells(X, 29) = WS.Range("G44") .Cells(X, 30) = WS.Range("H44") .Cells(X, 31) = WS.Range("I44") .Cells(X, 32) = WS.Range("G47") .Cells(X, 33) = WS.Range("H47") .Cells(X, 34) = WS.Range("I47") .Cells(X, 36).Resize(, 7) = Application.Transpose(WS.Range("G34").Resize(7)) .Cells(X, 43) = WS.Range("J41") .Cells(X, 44) = WS.Range("G49") End With Application.ScreenUpdating = True End Sub محو السحل بعد الترحيل. اظهار مسج خطئ حين لا يتم تعبئة كامل المعلومات . مسج اخر عند تعبئة الخلايا بشكل كامل " تم الترحيل ". في حال تم ادراج رقم الموظف في السابق لايتم عملية الترحيل ويظهر مسج " الرجاء التحقق من رقم الموظف ".

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

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

السلام عليكم ورحمة الله وبركاته اسعد الله مسائكم الرجاء المساعدة بعمل كود ترحيل البينات من شيت إلى اخر حسب الصورة والمرفق وتقبلو تحياتي DRAFT.rar

السلام عليكم ورحمة الله وبركاته ما شاء الله عليك يا ابو البراء ابدع بلا حدود في كل المواضيع التي تقوم بكتابتها جعل الله هذا العمل في ميزان حسناتك ونترقب المزيد من المواضيع المميزة ولكم تحياتي

السلام عليكم ورحمة الله وبركاته أخي الغالي أبو البراء الكود يعمل بشكل ممتاز وهذا ما كنت اريده ما شاء الله عليك فعلا استاذ الله يجعل هذا العمل في ميزان حسناتك ولكم تحياتي

استفسار اخير ولو غلبتك معي هل بالإمكان اضافة تعديل للكود بحيث يقوم بتحديد طول وعرض الصورة حسب الخلايا المدمجة اي بشكل اتوماتيك بدون ما اقوم بتعديك القيمة بشكل يدوي !!؟

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

بسم الله ماشاء الله عليك ( رائع انت يا أبو البراء ) تم تحميل المرفق ومراجعة الكود من والى النهاية والتعديل كان في :- السابق : Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height ): empphoto = "" بعد التعديل الكبير الذي استغرق الوقت الطويل والعناء وانا اشكرك على هذا المجهود الجبار :) Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height * 8): empphoto = "" اما الان اود تعديل اخر بسيط عند دمج الخلايا مرة اخرى العمودية والافقية لم ينجح الكود في تحديد الصورة في الاطار المطلوب مرفق عينة Insert Photo UDF Function Wesam.rar

حي الله ابو البراء واخيرا اسعدني مرورك وكنت في انتظارك :) بس للاسف يا الغالي المرفق ما عما يتحمل ؟؟؟

صورةتوضح عمل الكود مرفق نموذج اخر . Draft.rar

السلام عليكم ورحمة الله وبركاته لدي الكود السابق ولكن لايعمل عند دمج الخلايا وتظهر الصورة بشكل صغير Function empphoto(PicName) Dim CurrentCel As Range, Pic As Shape PicName = PicName: MyPath = ThisWorkbook.Path & "\Picture\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png") Set CurrentCel = Application.Caller For Each Pic In ActiveSheet.Shapes If Pic.Type = msoLinkedPicture Then If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then Pic.Delete Exit For End If End If Next For X = LBound(ChkPic) To UBound(ChkPic) If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): empphoto = "" Exit For Else empphoto = "" End If Next End Function ارجو المساعدة..

السلام عليكم ورحمة الله وبركاته لدي الكود السابق ولكن لايعمل عند دمج الخلايا وتظهر الصورة بشكل صغير Function empphoto(PicName) Dim CurrentCel As Range, Pic As Shape PicName = PicName: MyPath = ThisWorkbook.Path & "\Picture\": PicName = MyPath & PicName: ChkPic = Array(".jpg", ".bmp", ".gif", ".png") Set CurrentCel = Application.Caller For Each Pic In ActiveSheet.Shapes If Pic.Type = msoLinkedPicture Then If Pic.Top >= CurrentCel.Top And Pic.Top < CurrentCel.Top + CurrentCel.Height Then Pic.Delete Exit For End If End If Next For X = LBound(ChkPic) To UBound(ChkPic) If Not Dir(PicName & ChkPic(X), vbDirectory) = vbNullString Then Set Pic = ActiveSheet.Shapes.AddPicture(PicName & ChkPic(X), True, False, CurrentCel.Left, CurrentCel.Top, CurrentCel.Width, CurrentCel.Height): empphoto = "" Exit For Else empphoto = "" End If Next End Function ارجو المساعدة..

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

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

السلام عليكم ورحمة الله وبركاته تم تطبيق الكود وبالفعل قام بحذف كافة التول بوكس الموجود في الشيت بوركت اخي أبو البراء على المساعدة وجزاك الله خيرا ولكم تحياتي

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

السلام عليكم ورحمة الله وبركاته اسعد الله مسائكم اعضاء منتدانا الغالي لدي في مشكلة في اكسل عم الضغط على اي خانة في الملف يظهر مربع حوار غريب بدون طلب اضافته ارجو المساعدة. مرفق نموذج Draft.rar

تمام تم حل المشكلة يعطيك الف عافية على التفاعل السريع والشرح الوافي

السلام عليكم ورحمة الله وبركاته لدي مشكلة في الاكسل حيث انني في كل مرة اقوم في فتح الملف لا يقوم بتحديث بينات الحقول بشكل تلقائي الا بعد الظغط على الحقل في الشيت او اعادة كتابة الفورملا. مع العلم ان الفورملا صحيحة ولا يوجد بها اخطاء بالرجاء المساعدة . دمتم سالمين

اللَّهُمَّ رَبَّ النَّاسِ أَذْهِبِ الْبَاسَ, اشْفِهِ وَأَنْتَ الشَّافِي, لا شِفَاءَ إِلا شِفَاؤُكَ, شِفَاءً لا يُغَادِرُ سَقَمًا أسأل الله العظيم رب العرش العظيم أن تشفي أستاذنا الكبير عاجلاً غير آجل.

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

السلام عليكم ورحمة الله وبركاته اسعد الله صباحكم بالصحة والعافية هل هناك طريقة تقوم بترجمة من الانكليزي إلى العربي في الاكسل مثال + نموذج مرفق مع جزيل الشكر نموذج.rar