كود ترحيل قيمة أي خلية نشطة الى خلية مجاورة بزيادة واحد

[رضوان الشلي]

السلام عليكم

لوسمحتم ارغب في مساعدتكم لي في اعداد الآتي ببرنامج الاكسل ماكرو انيبل

تنفيذ ماكرو لترحيل قيمة أي خلية نشطة الى خلية مجاورة بزيادة واحد   ...   أي عند الضغط علي زر الماكرو الأخضر مثلا فيأخد القيمة الموجودة بالخلية الأولى ويرحلها للخلية المجاورة بزيادة عدد 1 .. أي إذا كانالعدد بالخلية القديمة 40 مثلا يصبح  41 بالخلية الجديدة

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

   ...  ملاحظة  ...  عندي 6 اعمدة وكل عمود به 200 خلية كما ان دائما الخلية الاصغر هي الخلية النشطة وملونة تلقائي باللون الاصفر

عنوان مخالف ....تــم تعديل وتغيير عنوان المشاركة ليعبر عن طلبك

الترحيل بالماكرو.xlsm

[حسين مامون]

جربهدا

نشط اي خلي عي العمود c او h

Sub test1()
If Not Intersect(Columns(3), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = Val(ActiveCell + 1)
End If
End Sub
Sub test2()
If Not Intersect(Columns(8), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = Val(ActiveCell)
End If
End Sub

كود ترحيل قيمة أي خلية نشطة الى خلية مجاورة بزيادة واحد.xlsm

[رضوان الشلي]

السلام عليكم

ماشاء الله عليك وفي ميزان حسناتك

نحن في الطريق الصحيح لاستكمال المعلومة

الازرار تعمل بشكل صحيح ولكن في العمود 3 والعمود 8  فقط ... وانا اريدها ان تعمل في العمود 3 و 4 و 5 وكذلك في العمود 8 و 9 و 10  لو عملت نسخ وغيرت 4 بدل 3 الخ ...    هل هذه الخطوات صحيحة ام لا   ...  

لا تعمل معي الان حيث احتاجها احيانا  undo كما طلبتها قبل القيمة وان   (x ) لم توضع علامة  test2 في  

مشكور كثيرا 

[حسين مامون]

Sub test1()
If Not Intersect(Columns(3), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = Val(ActiveCell + 1)
ActiveCell.Offset(, 3) = Val(ActiveCell + 1)

End If
End Sub
Sub test2()
If Not Intersect(Columns(8), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = Val(ActiveCell)
ActiveCell.Offset(, 3) = Val(ActiveCell)
If ActiveCell = 40 Then ActiveCell = ActiveCell & "x"
End If
End Sub

 

 

[رضوان الشلي]

السلام عليكم ورحمة الله

أولا شكرا للسادة المشرفين على الصرح الجميل أوفيسنا

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

 تنفيذ الماكرو كان رائعاً في الإثنان ولكن تنقصه اللمسة الأخيرة وهي مبينة بالملف المرفق

يرجى الأطلاع عليه ونعديله

جزاكم الله خيراً لما تفعلون وفي ميزان حسناتكم

والسلام عليكم ورحمة الله

الترحيل بالماكرو.xlsb

[حسين مامون]

مرحبا اخي الكريم

جرب المرفق 

الترحيل بالماكرو.xlsb

[رضوان الشلي]

السلام عليكم

سيدي بارك الله فيك واني شاكراً لأفضالكم ومجهوداتكم وان شاء الله في ميزان حسناتكم واني سعيد جدا لما توصلتم له

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

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

اليك الملف وكلي أمل في الوصول لللمسة الأخيرة التي تريحي من كل المشاق وهذا لن يأتي لو لم يتم تدخلكم في مساعدتي

لكم مني كل التحايا

والسلام عليكم ورحمة الله

الترحيل بالماكرو.xlsb

[حسين مامون]

الترحيل بالماكرو (1).xlsb

[حسين مامون]

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

Sub RN()
If Not Intersect(Columns(3), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = Val(ActiveCell + 1)
'=======
ElseIf Not Intersect(Columns(5), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell = "x" & ActiveCell
ActiveCell.Offset(, 8) = "x"
'=======
ElseIf Not Intersect(Columns(8), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 1) = ActiveCell
ActiveCell = "x" & ActiveCell
'=======
ElseIf Not Intersect(Columns(10), ActiveCell) Is Nothing Then
If ActiveCell = "" Then Exit Sub
ActiveCell.Offset(, 4) = "x"
ActiveCell = "x" & ActiveCell

End If
End Sub

 

الترحيل بالماكرو (1).xlsb

[رضوان الشلي]

السادة الموقرين

السيد حسين مأمون

تحية مسائية طيبة

بارك الله في اهدافكم النبيلة التي شجعتنا على مواصلة مبتغانا والمتنمثلة في ايجاد الحلول والتي لولاكم لما فرحنا وابتهجنا وكله في ميزان حسناتكم

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

 علما بأني غيرت صيغة الطلب حيث تمت الطلبات الاولى بكل سلاسة واملي في ان تنفدوا لي كود ترجيع لخطوة او اثنان للخلف

ارفق لكم الملف المعني

ولكم كل التقدير والاحترام

الترحيل بالماكرو.xlsb

[رضوان الشلي]

 السادة الكرام 

السلام عليكم ورحمة الله وبركاته

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

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

والله في عون العبد مادام العبد في عون أخيه

والسلام عليكم ورحمة الله وبركاته 

[حسين مامون]

اخي الكريم كلنا نعرف عند تنفيذ الماكرو يتم الغاء خاصية التراجع في الاكسيل

يمكنك انشاء عمود مساعد لهذه الغاية

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

هكذا يحفظ القيمة السابقة 

ولاسترجاعها انشاء كود بسيط  ينقد هذا الامر