استاذ ياسر الحمدلله وصلت الحل
Sub Tarh()
LR = [A58].End(xlUp).Row
If LR < 20 Then MsgBox "No data to shift": Exit Sub
nm = [b11]: dt = [b17]: bil = [K11]
Set Q_P = Union(Range("A20:A" & LR), Range("E20:E" & LR))
Set dsc = Range("B20:B" & LR)
n = dsc.Count
Sheets("الارشف").Activate
nr = [E9999].End(xlUp).Row + 1
dsc.Copy
Cells(nr, 7).PasteSpecial Paste:=xlPasteValues
Q_P.Copy
Cells(nr, 8).PasteSpecial Paste:=xlPasteValues
Range("E" & nr & ":E" & nr + n - 1) = dt
Range("F" & nr & ":F" & nr + n - 1) = nm
Range("D" & nr & ":D" & nr + n - 1) = bil
Sheets("المشتريات").Activate
Set dsc = dsc.Resize(n, 3)
dsc.Select
dsc.ClearContents
[b11:C11].ClearContents
Q_P.ClearContents
[K11] = [K11] + 1001
End Sub