مساعدة في ترحيلة

[أحمد علي (أبوعلي)]

أخواني وخبراء المنتدى

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

 

أسعد الله أوقاتكم بالخيرات

 

الملف المرفق في داخلة الشرح والمطلوب المساعد

وإذا أمكن شرح الأكواد على قدر الاستطاعة

 

أخوكم

أحمد علي

Book11.rar

[عاطف عبد العليم محمد]

السلام عليكم 

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

http://www.officena.net/ib/index.php?showtopic=47246&view=getnewpost

 

الموضوع باسم "طلب مساعدة لتكرار كود ترحيل".

وفقكم الله

[أحمد علي (أبوعلي)]

السلام عليكم أخي الكريم

أخذت نظرة على الملف الذي أشرت عليه ولكن ما أستطعت أنفذة على ملفي

بحكم الخبرة لذي جداً ضعيفة وجديد على عمل الأكواد وعيرها من البرمجة

 

أرجوا الافادة وجزاكم الله خير ....

[طارق محمود]

السلام عليكم

أخي العزيز

تفضل المرفق وبه ماطلبت

Book11_2.zip

[أحمد علي (أبوعلي)]

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

كيف حال الاستاذ/ طارق محمود

 

أشكرك أخي طارق على الجهود والله يجزيك خير

الملف حسب المطلوب بس عند الترحيل يقوم بنقل البيانات مع التنسيق

والمطلوب نقل البيانات فقط .... أرجو أن الفكرة واضحة

 

وأشكرك مرة أخرى

[طارق محمود]

الفكرة واضحة

 

تفضل المرفق

Book11_3.zip

[أحمد علي (أبوعلي)]

السلام عليكم أخي الاستاذ طارق

 

التعديل الأخير ممتاز وحسب الطلب ولكن:

 

عند ترحيل البيانات أول مرة ممتاز ولكن عندما يتم ترحيل البيانات في المرة الثانية

يقوم بحذف آخر سطر من البيانات المرحلة في الورقة الثانية ويبدا نسخ البيانات الثانية

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

 

وأشكرك على طول بالك

[طارق محمود]

السلام عليكم

عندك حق

 

 

Sub shiftt()

LR = [A9999].End(xlUp).Row

If LR < 6 Then MsgBox ("No records to shift, Will EXIT"): Exit SubnLR = Sheet2.[A9999].End(xlUp).Row

If nLR = 6 Then nLR = 7

Range("A6:A" & LR).Copy

Sheet2.Cells(nLR, 1).PasteSpecial Paste:=xlPasteValues

Range("B6:F" & LR).Copy
Sheet2.Cells(nLR, 3).PasteSpecial Paste:=xlPasteValues
Range("A6:F" & LR).ClearContents

End Sub

إستبدل السطرين الملونين بالأحمر بالسطرالتالي

 

nLR = Sheet2.[A9999].End(xlUp).Row+1

 

ليكون الكود كاملا كالتالي

Sub shiftt()
LR = [A9999].End(xlUp).Row
If LR < 6 Then MsgBox ("No records to shift, Will EXIT"): Exit Sub
nLR = Sheet2.[A9999].End(xlUp).Row+1

Range("A6:A" & LR).Copy
Sheet2.Cells(nLR, 1).PasteSpecial Paste:=xlPasteValues

Range("B6:F" & LR).Copy
Sheet2.Cells(nLR, 3).PasteSpecial Paste:=xlPasteValues
Range("A6:F" & LR).ClearContents

End Sub

وإن شاء الله ستحل المشكلة

[أحمد علي (أبوعلي)]

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

 

أشكرك أخي الأستاذ طارق

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