ترحيل صف من شيت الى شيت بناء على الخليه النشطة

[مختار حسين محمود]

الأخوة والأساتذة الكرام

 

طلب أحد الأخوة  نسخ الخلية النشطة مع صفها من شيت الى شيت آخر فى هذا الرابط

 

http://www.officena.net/ib/index.php?showtopic=62805

 

ولعموم الفائدة أضع بين أيديكم كود نسخ الخلية النشطة وبعدها عدد محدد من الخلايا وليكن 5 خلايا مثل النسخ من A5  الى  F5

Sub mokhtest2()
Application.ScreenUpdating = False
ActiveCell.Resize(1, 6).Copy Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) ' لنسخ ولصق النشطة بالفورمات وبعدها 5 خلايا
Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub

الجزئية ActiveCell.Resize(1, 6).Copy   معناها نسخ الخلية النشطة مع 5 خلايا بعدها فى نفس الصف وده = 6

 

الجزئية Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)   

هى وجهة اللصق  أول فارغة فى العمود 1 فى الشيت مستودع واللصق يكون للقيم والفورمات

 

باقى الكود للتسريع وتفريغ الذاكرة العشوائية

المرفق

copy row based on ActiveCell mokhtar .rar

[Yasser Fathi Albanna]

رائع أخى الحبيب مختار

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

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

بارك الله فيك أخي الحبيب مختار

إليك كود آخر لا يرقى لمستوى كودك بالطبع ..فكودك هو الأيسر والأسهل

Sub CopyRowActiveCell()
    Dim WS As Worksheet, SH As Worksheet
    Dim lrWS As Long, lrSH As Long, I As Long

    Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع")
    lrWS = ActiveCell.Row
    lrSH = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1

    For I = 1 To 6
        SH.Cells(lrSH, I) = WS.Cells(lrWS, I)
    Next I
End Sub

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

أو يمكن استخدام هذا الكود بدون اللجوء إلى استخدام طريقة النسخ أو الحلقات التكرارية

Sub CopyRowActiveCell()
    Dim WS As Worksheet, SH As Worksheet, LR As Long

    Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع")
    LR = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1

    SH.Cells(LR, 1).Resize(1, 6).Value = WS.Cells(ActiveCell.Row, 1).Resize(1, 6).Value
End Sub

[سليم حاصبيا]

 اخواني في المنتدى

لماذا لا تدعون المستخدم يختار عدد الصفوف  و الاعمدة المطلوبة ابتذاءً من الخلية المحددة (بدل ان يدخل الى الكود و يقوم بهذا الشيء)

عبر هذا الكود

Sub CopyRowActiveCell()
    Dim WS As Worksheet, SH As Worksheet, LR As Long

    Set WS = Sheets("Sheet1"): Set SH = Sheets("Sheet2")
    LR = SH.Cells(Rows.Count, 1).End(xlUp).Row
   
     myrow = Application.InputBox("حدد عدد الصفوف", Default:=1)
     mycol = Application.InputBox("حدد عدد الاعمدة", Default:=1)
ActiveCell.Resize(myrow, mycol).Copy
SH.Cells(LR + 1, 1).PasteSpecial (xlValues)

Application.CutCopyMode = False
End Sub

[مختار حسين محمود]

أخوتى وأساتذتى ياسر فتحى وياسر خليل و سليم حاصبيا بارك الله فيكم وجازاكم خيرا

 

أخى وأستاذى ياسر خليل  بدون مجاملات الأكواد المضافة أكثر من رائعة  وغاية فى الرقى 

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

واليك هذه الاضافة أيضا  تؤدى نفس الوظيفة بدون اللجوء إلى استخدام طريقة النسخ  كما هو الحال فى كودك الثانى بالمشاركة 4

Sub mokhtest3()
Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = Sheets("بيانات").Cells(ActiveCell.Row, 1).Resize(1, 6).Value

End Sub

تحياتى

[أبو أنس80]

فكرة رائعة تسليم ايديكم يا جماعة

[أبوبسمله]

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

لا اجد فى نفسى شىء اقدمه لكم غير الدعاء فارجو من الله العلى القدير ان يستجيب لدعائى ويجزيكم عنا خير الجزاء

بالتوفيق اخوانى الكرام