طلب تعديل بسيط على كود ترحيل بيانات الى موقع محدد داخل جدول.

[ماجد القثمي]

السلام عليكم

 

اخواني.. لدي طلب لتعديل كود ترحيل بيانات من ورقه عمل الى ورقع عمل اخرى ولكن داخل موقع محدد في جدول..

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

 

ارجو ممن لديه الوقت والخبرة ان يفيدني

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

الملف مرفق وبه بقيه تفاصيل الاستفسار

ملف طلب للمنتدى.rar

[ماجد القثمي]

للرفع مع التحيه

[ياسر خليل أبو البراء]

تفضل أخي الحبيب

جرب

ملف طلب للمنتدى.rar

[ماجد القثمي]

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

جزاك الله خير

الملف يعمل بشكل كامل

[ماجد القثمي]

اخي العزيز

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

لاني اضفت جدول ثالث ايضا

رابط الموضوع::

 

اخواني كتبت كود لترحيل بيانات من ورقه الى ورقه اخرى داخل جدول من 3 اقسام اعددته مسبقا

اريد ان ينتقل الترحيل من الجدول الاول الى الثاني الى الثالث في حال امتلاء الجدول الذي قبله بالبيانات

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

بقيه الشرح في الملف المرفق

 وشكرا

<<Sub test()

'Transfer order from top items table

For r = 4 To 57

If Cells(6, r).Value <> Empty Then

Cells(3, r).Copy

 

If Sheets("order").Cells(43, 3).Value <> Empty Then

Sheets("order").Cells(4, 7).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

Else

Sheets("order").Cells(4, 3).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End If

 

Cells(6, r).Copy

If Sheets("order").Cells(43, 4).Value <> Empty Then

Sheets("order").Cells(4, 8).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

Else

Sheets("order").Cells(4, 4).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End If

End If

Next

 

'Transfere order from bottom items table

For s = 4 To 59

If Cells(12, s).Value <> Empty Then

Cells(9, s).Copy

 

If Sheets("order").Cells(43, 3).Value <> Empty Then

Sheets("order").Cells(4, 7).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

Else

Sheets("order").Cells(4, 3).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End If

 

Cells(12, s).Copy

If Sheets("order").Cells(43, 4).Value <> Empty Then

Sheets("order").Cells(4, 8).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

Else

Sheets("order").Cells(4, 4).End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues

End If

 

 

End If

Next

End Sub>>

 

تعديل الى داخل الجدول.rar

[ماجد القثمي]

للرفع