السلام عليكم و رحمة الله وبركاته
تم عمل نقل البيانات في المرفق
Sub khutah()
On Error Resume Next
Application.ScreenUpdating = False
Range("B1:Z113").ClearContents
ActiveWorkbook.Calculation = xlManual
Dim Q
Dim W
Dim E
Dim R
Sheets("PLAN").Select
For Q = 2 To 111
For W = 1 To 111
If Cells(Q, 1) = Sheets("PlanC").Cells(W, 1) Then
R = 2
For E = 154 To 256
If Cells(Q, E).Value <> "" Then
Sheets("PlanC").Cells(W, R) = Cells(Q, E).Value
R = R + 1
End If
Next E
End If
Next W
Next Q
ActiveWorkbook.Calculation = xlAutomatic
End Sub
ومرفق شرح
AY____________.rar