نسخ اسطر من جدول بشرط

[فراسكو]

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

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

المصنف1.rar

[أبوعيد]

السلام عليكم

هذه محاولة سريعة

تفضل

المصنف1معدل.rar

[فراسكو]

بارك الله بك اخي ابو عيد لكن انت لم تختار كل الملف 

[رجب جاويش]

السلام عليكم

وهذه محاولة أخرى لإثراء الموضوع

كود فى حدث الصفحة بمجرد كتابة الكلمة المطلوبة يتم الترحيل

Private Sub Worksheet_Change(ByVal Target As Range)
Set sh = Sheets("الخلاصة")
LR = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
If Target.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
If Not Intersect(Target, Range("G:G")) Is Nothing Then
    If Not IsEmpty(Target) And Target.Text = "تخويل صادر" Or Target.Text = "شهيد" Or Target.Text = "دورة" Or Target.Text = "نقل" Or Target.Text = "استخدام" Or Target.Text = "حماية" Then
        Target.Offset(0, -6).Resize(1, 4).Copy
        sh.Range("A" & LR).PasteSpecial xlPasteValues
        sh.Range("E" & LR).Value = Target
    End If
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set sh = Nothing
End Sub

المصنف2.rar

[فراسكو]

استاذي الفاضل استاذ رجب

سلمت يدك على هذا الكود الرائع وبارك الله فيك 

هل يمكن ان توسع نطاقا الكود الى نهاية الجدول يعني ياخذ مجال اوسع 

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

[فراسكو]

اتمنى ما نسيتوني 

[رجب جاويش]

السلام عليكم

تفضل أخى

تم تعديل بسيط

وجعل الكود يعمل عن طريق زر

حتى يمكن تنفيذ طلبك

جرب وأخبرنى بالنتيجة

Sub ragab()
Dim c As Range
Set sh = Sheets("الخلاصة")
LR = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A3:E1000").ClearContents
For Each c In Range("G4:G" & LR)
  If Not IsEmpty(c) And c.Text = "تخويل صادر" Or c.Text = "شهيد" _
    Or c.Text = "دورة" Or c.Text = "نقل" Or c.Text = "استخدام" Or c.Text = "حماية" Then
    c.Offset(0, -6).Resize(1, 4).Copy
    LR1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    sh.Range("A" & LR1).PasteSpecial xlPasteValues
    sh.Range("E" & LR1).Value = c
   End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set sh = Nothing
End Sub

المصنف3.rar

[فراسكو]

استاذ رجب 

هذا الكود رائع لكن يتوسع اكثر لغاية الخلية رقم 1270 من الجدول يتعمم الكود لهذا التسلسل وحسب هذا المرفق 

اما انت اذا احببت ان تزيد من قوة الكود وترتيب المصنف فاكون شاكر لك 

المصنف الجديد.rar

تم تعديل مايو 9, 2014 بواسطه فراسكو

[رجب جاويش]

أخى الفاضل / فراسكو

الكود يعمل الى آخر صف أيا كان رقمه

وهو يعمل فى المرفق حتى الصف 1270

[فراسكو]

اهديك تحياتي وحبي واخلاصي ودعائي لك بالخير المديد ويكثر من امثالك الشرفاء 

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

[رجب جاويش]

أخى الفاضل / فراسكو

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

وان شاء الله أقوم بشرح الكود