يرجى فيما بعد أن تظهر لنا محاولاتك في سبيل الوصول للحل ، فالمنتدى تعليمي وليس خدمي
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