طلب كود ترحيل من خلايا متفرقة إلى آخر صف فيه بيانات

[مداد_1423]

السلام عليكم

تحية طيبة

أدام لله لكم الصحة والسلامة جميعا

سؤالي تختصره الصورة

 

كود ترحيل الخلية Y1 إلى آخر صف +1 وفي نفس الصف ترحل الخلايا 

AM6:BQ6

إلى E:Ai

الترحيل يكون بيانات

 

شكرا لكل من مر على الموضوع

وجزيل الشكر وخالص الدعاء لمن ساعدني

 

تحياتي

INI.xlsx

[حسين مامون]

تفضل جرب  المرفق

INI.xlsm

[مداد_1423]

أستاذي حسين

بارك الله في صحتك ووقتك وكثر الله من أمثالك

وأدام الله لك الصحة ومتعك بعافيتك

 

هذا هو المطلوب بارك الله فيك وشكر الله لك

هنيئا لصاحب العلم في زكاة علمه

تحياتي

[مداد_1423]

هل ممكن إضافة شرط:

إذا كانت الخلية Y1 موجودة في العامود A فيكون فيه رسالة تحذيرية أنه موجود ولا يقبل التكرار؟ ـ

 

  الكود في الملف المرفق أعلاه من إبداع حسين مامون جزاه الله خيراً

Sub TEST()
Dim lr

With Sheets("HR")
lr = .Cells(Rows.Count, 1).End(3).Row + 1
    If .[y1] = "" Then Exit Sub
    .Range("a" & lr).Value = .[y1].Value
    .Range("e" & lr).Resize(1, 31).Value = .Range("am6").Resize(1, 31).Value
    End With
End Sub

 

[حسين مامون]

غير الماكرو بهذا

Sub TEST()
Dim lr

With Sheets("HR")
lr = .Cells(Rows.Count, 1).End(3).Row + 1
 If Application.WorksheetFunction.CountIf(.Range("A5:A10000"), .Range("y1")) > 0 _
 Then MsgBox "الرقم الذي ادخاله موجود في القائمة", vbInformation: Exit Sub
 
    If .[y1] = "" Then Exit Sub
    .Range("a" & lr).Value = .[y1].Value
    .Range("e" & lr).Resize(1, 31).Value = .Range("am6").Resize(1, 31).Value
    End With
End Sub

 

[مداد_1423]

جزاك الله خير الجزاء أستاذ حسين

 

الكود يعمل بكفاءة كما أحب ، شكر الله لك وبارك فيك

 

تحياتي