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

فنان :)

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

السلام عليكم ورحمة الله وبركانه اسعد الله ايامكم واتمها بالخير الرجاء المساعدة في اضافة تعديل على كود الترحيل ()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 ارجو المساعدة..