اذهب الي المحتوي
أوفيسنا

توزيع قيم حسب الرقم المحدد


الردود الموصى بها

خوانى الاعزاء اتمنى المساعدة من خبراء الاكسيل

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

1 - عند وضع القيمة فى الصف الاول ثم وضع الرقم فى الصف الثانى يتم وضع هذة القيمة فى الصف المقابل لها ثم تفريغ نفس الصف حتى اقدر ان اضع قيمة اخرى فى نفس هذا الصف وقيمة اخرى ......الخ .

2 - لو امكن اعطاء رسالة ( هل تريد الحفظ ) قبل ان يتم تفريغ الصف حتى اكتب فى نفس الخلية مرة اخرى حتى يكون بامكانى وضع كل هذه القيم فى صف

واحد فقط وشكرا جزيلا لكم

test 22.RAR

رابط هذا التعليق
شارك

شكرا لك اخى عبدالله

ما اريدة ببساطة لو نظرت الى عمود القيمة سنجد اول قيمة هى 1000 وعمود الرقم ستجد اول رقم هو 1 اذا قمت انت بتغيير هذا الرقم من 1 الى 2 ستجد ال 1000 عند العمود الذى يسمى 2 واذا غيرت الى 3 ستجد ال 1000 عند العمود الذى يسمى 3 ............ هكذا ارجو التجربة

وما اريدة من حضرتك هو ان ادخل مثلا 1000 فى عمود القيم واكتب رقم 1 فى عمود الرقم يعطينى رسالة ( هل تريد الحفظ ) ( نعم او لا ) عند اختيار نعم يتم حفظ ال 1000 تحت العمود رقم 1 ثم يتم مسح ال 1000 وايضا رقم 1 ثم اكتب مرة اخرى فى نفس الخلية قيمة 2000 ولكن فى هذة المرة يكون الرقم 5 او 4 مثلا ويعطى رسالة ( هل تريد الحفظ ) ( نعم او لا ) ثم يحفظ فى العمود 4 او 5 حسب اختيارى .

كل ما اريدة هو وضع اكثر من قيمة فى صف واحد ولكن يكون ذلك عن طريق ( عمود القيمة وعمود الرقم ) وليس يدوى

ارجو ان تساعدنى واسف على الاطالة

وشكرا

رابط هذا التعليق
شارك

السلام عليكم

جرب المرفق (اكتب القيمة ثم اختر الرقم وبعد الموافقة على النقل سيتم مسح القيمة والرقم فاذا اردت ان تنقل قيمة اخرى ادخل القيمة ثم اختر الرقم وهكذا)

test 22.RAR

رابط هذا التعليق
شارك

السلام عليكم

ممكن اشارك اخى عبد الله بهذا الحل السريع

لضيق الوقت ان كان المطلوب نكمل


Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 4 Then Exit Sub

Cells(Target.Row, Target.Cells.Offset(0, Target.Value).Column).Value = Target.Cells.Offset(0, -1).Value

End Sub

TEST 3.rar

رابط هذا التعليق
شارك

اخوانى كم انا عاجز عن شكركم وزاد الله فى علمكم كى تعلموه الى غيركم شكرا جدا المثالين اروع من بعض وهو بالفعل ما اريدة .

هل لى ان اقوم بسؤال اخر يتعلق بنفس الموضوع لو سمحتوا لى .

السؤال الى حد ما اعم هو

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

الاول هو رقم المسلسل

و الثانى هو الشهر

مرفق لحضراتكم ومتشكر مرة اخرى واسف على الاطالة

test 5.RAR

رابط هذا التعليق
شارك

ان شاء الله هذا الكود يفي بالغرض


Sub Abu_Ahmed()

Set ws = Sheets("SHEET!")

LR = ws.Range("d" & Rows.Count).End(xlUp).Row

For i = 4 To LR

sh = Cells(i, 4).Value

Sheets(sh).Cells(i, ws.Cells(i, 6).Value + 2).Value = ws.Cells(i, 5).Value

Next

End Sub

ضعه في زر أمر في الورقة SHEET!

رابط هذا التعليق
شارك

السلام عليكم

لاثراء الموضوع

في المطلوب الاول يمكنك استخدام الكود التالي


Sub Abu_Ahmed()

Abdulla = MsgBox(" لقد طلبت ترحيل القيمة المحددة الى الموقع المحدد ومسح البيانات السابقة", _

vbYesNo + vbQuestion, "تحذير")

If Abdulla = vbYes Then ActiveCell.Offset(0, ActiveCell.Value).Value = ActiveCell.Cells.Offset(0, -1).Value

ActiveCell.Cells.Offset(0, -1).ClearContents

End Sub

او يمكنك استخدام الكود التالي في حدث التغيير

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 4 Then Exit Sub

Target.Offset(0, Target.Value).Value = Target.Cells.Offset(0, -1).Value

End Sub

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

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Not Intersect(Target, [d4:d27]) Is Nothing Then

Dim Sht As Worksheet

For Each Sht In Application.Worksheets

If Sht.Name = Target.Value Then

Sht.Cells(Target.Row, Target.Offset(0, 2).Value + 2) = Target.Offset(0, 1).Value

Target.Offset(0, -1).Select

Exit Sub

End If

Next Sht

End If

End Sub

مرفق ملف

  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information