كود نقل صفوف على حسب الاسم المكتوب في الخلية

[محمد عبد الناصر]

احتاج الى كود يقوم بنقل الصفوف على حسب الاسم المكتوب في الخلية A2 فاذا كان الاسم مثلا رخام ان يقوم بالنقل اذا كان مكتوب كلمة رخام 
فمثلا اذا كان مكتوب توريد وتركيب رخام ان يقوم بنقل الصف

تلوين.xlsm

[وجيه شرف الدين]

اتفضل الشيت لعله بفى بالغرض اما بالنسبة شبت الدمج انظر اليه قد التعديل على الكود

نسخة من تلوين 222.xlsm

[محي الدين ابو البشر]

جرب

تلوين.xlsm

[محمد عبد الناصر]

ماشاء الله استاذ محي الدين هو المطلوب تماما

استاذ محي الدين لو عايز اخليه ياخذ الملفات قص وليس نسخ ممكن ؟ بحيث انه يشيل الاسطر التي تم نقلها لا اريدها اريد ان يعمل قص وليس نسخ

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

بعد اذن الاستاذ وجيه

لا استطيع الا أن أعطي ملاحظات

 لماذا لا نستغني عن الحلقة التكرارية  (J) الثانية  ؟؟  لأن الحلقات التكرارية ترهق البرنامج اذا كانت البيانات كبيرة
  و ذلك  باعتماد هذا الكود

Sub aa()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim sh As Worksheet: Set sh = Sheets("Sheet2")
sh.Range("a7:e55") = ""
k = 7
lr = ws.Range("a" & Rows.Count).End(xlUp).Row
For i = 7 To lr
  If ws.Range("b2") = ws.Range("c" & i) Then
     sh.Cells(k, 1).Resize(, 5).Value = _
     ws.Range("A" & i).Resize(, 5).Value
    k = k + 1
  End If
Next
sh.Activate
End Sub

 

[وجيه شرف الدين]

حبيبى استاذ سليم وهو فى استاذن معلم من تلميذه وهو بنتعلم منكم

[عبدالفتاح في بي اكسيل]

اعتقد  انه  بالفلترة  افضل  من الحلقات  التكرارية  

 

Sub cutpaste_Rows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set srcWS = Sheets("sheet1")
    Set desWS = Sheets("sheet2")
    With srcWS
        .Cells(6, 1).CurrentRegion.AutoFilter 3, Range("a2").Value
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
        .AutoFilter.Range.Offset(1).EntireRow.Delete
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

تلوين (1).xlsm

[وجيه شرف الدين]

واثراء للموضوع هذا حل اخر بالمعادلات

نسخة من تلوين666.xlsm

[محمد عبد الناصر]

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

[محي الدين ابو البشر]

إليك

تلوين.xlsm

[محمد عبد الناصر]

ما شاء الله استاذ محي الدين بارك الله فيك وفي علمك وزادك من علمه