مطلوب كود ترحيل

Sub Test()

    Dim ws As Worksheet, sh As Worksheet, m As Long, r As Long

    Application.ScreenUpdating = False

        Set ws = ThisWorkbook.Worksheets("Sh1")

        Set sh = ThisWorkbook.Worksheets("Sh2")

        m = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1

        For r = 15 To 20

            If ws.Cells(r, 1).Value <> "" Then

                sh.Range("A" & m).Resize(1, 10).Value = Array(ws.Cells(r, 1).Value, ws.Cells(r, 3).Value, ws.Cells(r, 6).Value, ws.Range("D4").Value, ws.Range("H4").Value, ws.Range("H10").Value, ws.Cells(r, 10).Value, ws.Cells(r, 12).Value, ws.Range("D12").Value, ws.Range("C34").Value)

                m = m + 1

            End If

        Next r

    Application.ScreenUpdating = True

End Sub