كود حذف و ترحيل

[علي عبد المنعم]

المطلوب في المثال

ترحيل و حذف.xlsm

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

جرب هذا الملف

الماكرو

Option Explicit
Sub del_row()
    Dim i%, k%
    Dim st$: st = "حذف"
    Dim Main As Worksheet: Set Main = Sheets("البيانات")
    Dim Source As Worksheet: Set Source = Sheets("المحذوف")
    Dim lrB%
    If ActiveSheet.Name <> Main.Name Then Exit Sub
    
k = Main.Range("a1").CurrentRegion.Rows.Count
 For i = 2 To k
    lrB = Source.Cells(Rows.Count, 1).End(3).Row + 1
    If i > k Then Exit For
       If Main.Cells(i, 5) = st Then
           Source.Cells(lrB, 1).Resize(1, 5).Value = _
           Main.Cells(i, 1).Resize(1, 5).Value
           Cells(i, 1).EntireRow.Delete: i = i - 1: k = k - 1
       End If
  Next
End Sub

الملف مرفق

 

ترحيل و حذف salim.xlsm

[علي عبد المنعم]

شكرا لك استاذ سليم و للمنتدى المحترم اوفيسنا