السلام عليكم ورحمة الله
انسخ الكود التالى والصقه فى موديول
وخصص له زر
Sub TransrerData()
Dim ws As Worksheet, sh As Worksheet
Dim LR As Long, LS As Long
Dim R As Integer, S As Integer, p As Integer, Cod As Byte, Cod2 As Byte
Dim Qty As Long, Qty2 As Long
Set ws = Sheets("ÇÑÔíÝ")
Set sh = Sheets("ÈíÇä ÊÌãíÚì")
sh.Range("B10:K100").ClearContents
Application.ScreenUpdating = False
LR = ws.Range("E" & Rows.Count).End(xlUp).Row
For R = 10 To LR
Cod = WorksheetFunction.CountIf(Range(ws.Cells(10, "E"), _
ws.Cells(R, "E")), ws.Cells(R, "E"))
If Cod = 1 Then
sh.Cells(R, "B") = ws.Cells(R, "E")
sh.Cells(R, "C") = ws.Cells(R, "F")
sh.Cells(R, "D") = ws.Cells(R, "G")
sh.Cells(R, "F") = ws.Cells(R, "I")
Qty = WorksheetFunction.SumIf(Range(ws.Cells(10, "E"), ws.Cells(LR, "E")), _
sh.Cells(R, "B"), Range(ws.Cells(10, "H"), ws.Cells(LR, "H")))
sh.Cells(R, "E") = Qty
End If
Next
LS = ws.Range("M" & Rows.Count).End(xlUp).Row
p = 9
For S = 10 To LS
Cod2 = WorksheetFunction.CountIf(Range(ws.Cells(10, "M"), _
ws.Cells(S, "M")), ws.Cells(S, "M"))
If Cod2 = 1 Then
p = p + 1
sh.Cells(p, "G") = ws.Cells(S, "M")
sh.Cells(p, "H") = ws.Cells(S, "N")
sh.Cells(p, "I") = ws.Cells(S, "O")
sh.Cells(p, "K") = ws.Cells(S, "Q")
Qty2 = WorksheetFunction.SumIf(Range(ws.Cells(10, "M"), ws.Cells(LS, "M")), _
sh.Cells(p, "G"), Range(ws.Cells(10, "P"), ws.Cells(LS, "P")))
sh.Cells(p, "J") = Qty2
End If
Next
Application.ScreenUpdating = True
End Sub