أخي العزيز " ياسر " هل ممكن تعديل على الكود الترحيل التالي الذي هو أحد أبداعاتك .. لكي نتخلص من القص واللصق والتكرار... وكذلك من مسألة Clear content مابعد الترحيل لكي لا يقوم بتكرار ترحيل نفس الحقل أو عند تغيير الحقل
Sub TarhilData()
Dim WS As Worksheet, SH As Worksheet
Dim X As Long, Y As Long, Cell As Range
Dim lRow As Long
Set WS = Sheets("ÇáÈíÇäÇÊ"): Set SH = Sheets("ÃÌæÑ ÇáØÈíÈ")
Application.ScreenUpdating = False
For Each Cell In WS.Range("P2:p11")
If Not IsEmpty(Cell) Then
X = Application.WorksheetFunction.Match(Cell.Value, SH.Rows(1), 0)
lRow = SH.Cells(49, X).End(xlUp).Row + 1
WS.Range(Cell.Offset(, -14), Cell.Offset(, -12)).Copy
SH.Cells(lRow, X).PasteSpecial xlPasteValues
Cell.Offset(, 12).Copy
SH.Cells(lRow, X + 8).PasteSpecial xlPasteValues
On Error Resume Next
Y = Application.WorksheetFunction.Match(Cell.Offset(, -15), Range(SH.Cells(2, X), SH.Cells(2, X + 8)), 0)
SH.Cells(lRow, X + Y - 1).Value = Cell.Offset(, -1).Value
On Error GoTo 0
End If
Next Cell
Application.CutCopyMode = False
Application.ScreenUpdating = True
End
جدول إجور.rar