إن شاء اللّه يفيدك هذا الكود
Sub mas()
Application.ScreenUpdating = 0
Dim lr1 As Long, lr2 As Long, r As Long, c As Long, n As Long
lr1 = Sheet1.Cells(Rows.Count, 1).End(3).Row
lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
Sheet2.Rows("4:" & IIf(lr2 < 4, 4, lr2)).Delete Shift:=xlUp
For r = 6 To lr1
c = 0
Sheet1.Select
lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
If Evaluate("=COUNTIF($E$6:E" & r & ",E" & r & ")") = 1 Then
Sheet1.Range("A5:N5").Copy
Sheet2.Select
Sheet2.Range("A" & lr2 + 2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheet2.Range("f" & lr2 + 1) = Sheet1.Range("e" & r)
Sheet2.Range("a" & lr2 + 2) = c + 1
Sheet2.Range("b" & lr2 + 2 & ":N" & lr2 + 2).Value = Sheet1.Range("b" & r & ":N" & r).Value
c = c + 1
For n = r + 1 To lr1
If Sheet1.Range("e" & n) = Sheet1.Range("e" & r) Then
lr2 = Sheet2.Cells(Rows.Count, 1).End(3).Row
Sheet2.Range("A" & lr2 & ":N" & lr2).Copy
Range("A" & lr2 + 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Sheet2.Range("a" & lr2 + 1) = c + 1
Sheet2.Range("b" & lr2 + 1 & ":N" & lr2 + 1).Value = Sheet1.Range("b" & n & ":N" & n).Value
c = c + 1: Sheet2.Range("A4").Select
End If
Next n
End If
Next r
Sheet2.Select
Application.ScreenUpdating = 1
MsgBox "Done by mr-mas.com"
End Sub
وهذا ملفك بعد التعديل
بالتوفيق
الترحيل على حسب الوظيفة.xlsm